Theory Executable_Euclidean_Space

section ‹Euclidean Space: Executability›
theory Executable_Euclidean_Space
imports
  "HOL-Analysis.Multivariate_Analysis"
  "List-Index.List_Index"
  "HOL-Library.Float"
  Affine_Arithmetic_Auxiliarities
begin

subsection ‹Ordered representation of Basis and Rounding of Components›

class executable_euclidean_space = ordered_euclidean_space +
  fixes Basis_list eucl_down eucl_truncate_down eucl_truncate_up
  assumes eucl_down_def:
    "eucl_down p b = (∑i ∈ Basis. round_down p (b ∙ i) *⇩_R i)"
  assumes eucl_truncate_down_def:
    "eucl_truncate_down q b = (∑i ∈ Basis. truncate_down q (b ∙ i) *⇩_R i)"
  assumes eucl_truncate_up_def:
    "eucl_truncate_up q b = (∑i ∈ Basis. truncate_up q (b ∙ i) *⇩_R i)"
  assumes Basis_list[simp]: "set Basis_list = Basis"
  assumes distinct_Basis_list[simp]: "distinct Basis_list"
begin

lemma length_Basis_list:
  "length Basis_list = card Basis"
  by (metis Basis_list distinct_Basis_list distinct_card)

end

lemma eucl_truncate_down_zero[simp]: "eucl_truncate_down p 0 = 0"
  by (auto simp: eucl_truncate_down_def truncate_down_zero)

lemma eucl_truncate_up_zero[simp]: "eucl_truncate_up p 0 = 0"
  by (auto simp: eucl_truncate_up_def)

subsection ‹Instantiations›

instantiation real::executable_euclidean_space
begin

definition Basis_list_real :: "real list" where
  "Basis_list_real = [1]"

definition "eucl_down prec b = round_down prec b"
definition "eucl_truncate_down prec b = truncate_down prec b"
definition "eucl_truncate_up prec b = truncate_up prec b"

instance proof qed (auto simp: Basis_list_real_def eucl_down_real_def eucl_truncate_down_real_def
  eucl_truncate_up_real_def)

end

instantiation prod::(executable_euclidean_space, executable_euclidean_space)
  executable_euclidean_space
begin

definition Basis_list_prod :: "('a × 'b) list" where
  "Basis_list_prod =
    zip Basis_list (replicate (length (Basis_list::'a list)) 0) @
    zip (replicate (length (Basis_list::'b list)) 0) Basis_list"

definition "eucl_down p a = (eucl_down p (fst a), eucl_down p (snd a))"
definition "eucl_truncate_down p a = (eucl_truncate_down p (fst a), eucl_truncate_down p (snd a))"
definition "eucl_truncate_up p a = (eucl_truncate_up p (fst a), eucl_truncate_up p (snd a))"

instance
proof
  show "set Basis_list = (Basis::('a*'b) set)"
    by (auto simp: Basis_list_prod_def Basis_prod_def elim!: in_set_zipE)
      (auto simp: Basis_list[symmetric] in_set_zip in_set_conv_nth simp del: Basis_list)
  show "distinct (Basis_list::('a*'b)list)"
    using distinct_Basis_list[where 'a='a] distinct_Basis_list[where 'a='b]
    by (auto simp: Basis_list_prod_def Basis_list intro: distinct_zipI1 distinct_zipI2
      elim!: in_set_zipE)
qed
  (auto simp: eucl_down_prod_def eucl_truncate_down_prod_def eucl_truncate_up_prod_def
    sum_Basis_prod_eq inner_add_left inner_sum_left inner_Basis eucl_down_def
    eucl_truncate_down_def eucl_truncate_up_def
    intro!: euclidean_eqI[where 'a="'a*'b"])

end

lemma eucl_truncate_down_Basis[simp]:
  "i ∈ Basis ⟹ eucl_truncate_down e x ∙ i = truncate_down e (x ∙ i)"
  by (simp add: eucl_truncate_down_def)

lemma eucl_truncate_down_correct:
  "dist (x::'a::executable_euclidean_space) (eucl_down e x) ∈
    {0..sqrt (DIM('a)) * 2 powr of_int (- e)}"
proof -
  have "dist x (eucl_down e x) = sqrt (∑i∈Basis. (dist (x ∙ i) (eucl_down e x ∙ i))⇧²)"
    unfolding euclidean_dist_l2[where 'a='a] L2_set_def ..
  also have "… ≤ sqrt (∑i∈(Basis::'a set). ((2 powr of_int (- e))⇧²))"
    by (intro real_sqrt_le_mono sum_mono power_mono)
      (auto simp: dist_real_def eucl_down_def abs_round_down_le)
  finally show ?thesis
    by (simp add: real_sqrt_mult)
qed

lemma eucl_down: "eucl_down e (x::'a::executable_euclidean_space) ≤ x"
  by (auto simp add: eucl_le[where 'a='a] round_down eucl_down_def)

lemma eucl_truncate_down: "eucl_truncate_down e (x::'a::executable_euclidean_space) ≤ x"
  by (auto simp add: eucl_le[where 'a='a] truncate_down)

lemma eucl_truncate_down_le:
  "x ≤ y ⟹ eucl_truncate_down w x ≤ (y::'a::executable_euclidean_space)"
  using eucl_truncate_down
  by (rule order.trans)

lemma eucl_truncate_up_Basis[simp]: "i ∈ Basis ⟹ eucl_truncate_up e x ∙ i = truncate_up e (x ∙ i)"
  by (simp add: eucl_truncate_up_def truncate_up_def)

lemma eucl_truncate_up: "x ≤ eucl_truncate_up e (x::'a::executable_euclidean_space)"
  by (auto simp add: eucl_le[where 'a='a] round_up truncate_up_def)

lemma eucl_truncate_up_le: "x ≤ y ⟹ x ≤ eucl_truncate_up e (y::'a::executable_euclidean_space)"
  using _ eucl_truncate_up
  by (rule order.trans)

lemma eucl_truncate_down_mono:
  fixes x::"'a::executable_euclidean_space"
  shows "x ≤ y ⟹ eucl_truncate_down p x ≤ eucl_truncate_down p y"
  by (auto simp: eucl_le[where 'a='a] intro!: truncate_down_mono)

lemma eucl_truncate_up_mono:
  fixes x::"'a::executable_euclidean_space"
  shows "x ≤ y ⟹ eucl_truncate_up p x ≤ eucl_truncate_up p y"
  by (auto simp: eucl_le[where 'a='a] intro!: truncate_up_mono)

lemma infnorm[code]:
  fixes x::"'a::executable_euclidean_space"
  shows "infnorm x = fold max (map (λi. abs (x ∙ i)) Basis_list) 0"
  by (auto simp: Max.set_eq_fold[symmetric] infnorm_Max[symmetric] infnorm_pos_le
    intro!: max.absorb2[symmetric])

declare Inf_real_def[code del]
declare Sup_real_def[code del]
declare Inf_prod_def[code del]
declare Sup_prod_def[code del]
declare [[code abort: "Inf::real set ⇒ real"]]
declare [[code abort: "Sup::real set ⇒ real"]]
declare [[code abort: "Inf::('a::Inf * 'b::Inf) set ⇒ 'a * 'b"]]
declare [[code abort: "Sup::('a::Sup * 'b::Sup) set ⇒ 'a * 'b"]]

lemma nth_Basis_list_in_Basis[simp]:
  "n < length (Basis_list::'a::executable_euclidean_space list) ⟹ Basis_list ! n ∈ (Basis::'a set)"
  by (metis Basis_list nth_mem)

subsection ‹Representation as list›

lemma nth_eq_iff_index:
  "distinct xs ⟹ n < length xs ⟹ xs ! n = i ⟷ n = index xs i"
  using index_nth_id by fastforce

lemma in_Basis_index_Basis_list: "i ∈ Basis ⟹ i = Basis_list ! index Basis_list i"
  by simp

lemmas [simp] = length_Basis_list

lemma sum_Basis_sum_nth_Basis_list:
  "(∑i∈Basis. f i) = (∑i<DIM('a::executable_euclidean_space). f ((Basis_list::'a list) ! i))"
  apply (rule sum.reindex_cong[OF _ _ refl])
   apply (auto intro!: inj_on_nth)
  by (metis Basis_list image_iff in_Basis_index_Basis_list index_less_size_conv length_Basis_list lessThan_iff)

definition "eucl_of_list xs = (∑(x, i)←zip xs Basis_list. x *⇩_R i)"

lemma eucl_of_list_nth:
  assumes "length xs = DIM('a)"
  shows "eucl_of_list xs = (∑i<DIM('a::executable_euclidean_space). (xs ! i) *⇩_R ((Basis_list::'a list) ! i))"
  by (auto simp: eucl_of_list_def sum_list_sum_nth length_Basis_list assms atLeast0LessThan)

lemma eucl_of_list_inner:
  fixes i::"'a::executable_euclidean_space"
  assumes i: "i ∈ Basis"
  assumes l: "length xs = DIM('a)"
  shows "eucl_of_list xs ∙ i = xs ! (index Basis_list i)"
  by (simp add: eucl_of_list_nth[OF l] inner_sum_left assms inner_Basis
      nth_eq_iff_index sum.delta if_distrib cong: if_cong)

lemma inner_eucl_of_list:
  fixes i::"'a::executable_euclidean_space"
  assumes i: "i ∈ Basis"
  assumes l: "length xs = DIM('a)"
  shows "i ∙ eucl_of_list xs = xs ! (index Basis_list i)"
  using eucl_of_list_inner[OF assms] by (auto simp: inner_commute)


definition "list_of_eucl x = map ((∙) x) Basis_list"

lemma index_Basis_list_nth[simp]:
  "i < DIM('a::executable_euclidean_space) ⟹ index Basis_list ((Basis_list::'a list) ! i) = i"
  by (simp add: index_nth_id)

lemma list_of_eucl_eucl_of_list[simp]:
  "length xs = DIM('a::executable_euclidean_space) ⟹ list_of_eucl (eucl_of_list xs::'a) = xs"
  by (auto simp: list_of_eucl_def eucl_of_list_inner intro!: nth_equalityI)

lemma eucl_of_list_list_of_eucl[simp]:
  "eucl_of_list (list_of_eucl x) = x"
  by (auto simp: list_of_eucl_def eucl_of_list_inner intro!: euclidean_eqI[where 'a='a])


lemma length_list_of_eucl[simp]: "length (list_of_eucl (x::'a::executable_euclidean_space)) = DIM('a)"
  by (auto simp: list_of_eucl_def)

lemma list_of_eucl_nth[simp]: "n < DIM('a::executable_euclidean_space) ⟹ list_of_eucl x ! n = x ∙ (Basis_list ! n::'a)"
  by (auto simp: list_of_eucl_def)

lemma nth_ge_len: "n ≥ length xs ⟹ xs ! n = [] ! (n - length xs)"
  by (induction xs arbitrary: n) auto

lemma list_of_eucl_nth_if: "list_of_eucl x ! n = (if n < DIM('a::executable_euclidean_space) then x ∙ (Basis_list ! n::'a) else [] ! (n - DIM('a)))"
  apply (auto simp: list_of_eucl_def )
  apply (subst nth_ge_len)
   apply auto
  done

lemma list_of_eucl_eq_iff:
  "list_of_eucl (x::'a::executable_euclidean_space) = list_of_eucl (y::'b::executable_euclidean_space) ⟷
  (DIM('a) = DIM('b) ∧ (∀i < DIM('b). x ∙ Basis_list ! i = y ∙ Basis_list ! i))"
  by (auto simp: list_eq_iff_nth_eq)

lemma eucl_le_Basis_list_iff:
  "(x::'a::executable_euclidean_space) ≤ y ⟷
  (∀i<DIM('a). x ∙ Basis_list ! i ≤ y ∙ Basis_list ! i)"
  apply (auto simp:  eucl_le[where 'a='a])
  subgoal for i
    subgoal by (auto dest!: spec[where x="index Basis_list i"])
    done
  done

lemma eucl_of_list_inj: "length xs = DIM('a::executable_euclidean_space) ⟹ length ys = DIM('a) ⟹
  (eucl_of_list xs::'a) = eucl_of_list (ys) ⟹ xs = ys"
  apply (auto intro!: nth_equalityI simp: euclidean_eq_iff[where 'a="'a"] eucl_of_list_inner)
  using nth_Basis_list_in_Basis[where 'a="'a"]
  by fastforce

lemma eucl_of_list_map_plus[simp]:
  assumes [simp]: "length xs = DIM('a::executable_euclidean_space)"
  shows "(eucl_of_list (map (λx. f x + g x) xs)::'a) =
    eucl_of_list (map f xs) + eucl_of_list (map g xs)"
  by (auto intro!: euclidean_eqI[where 'a='a] simp: algebra_simps eucl_of_list_inner)

lemma eucl_of_list_map_uminus[simp]:
  assumes [simp]: "length xs = DIM('a::executable_euclidean_space)"
  shows "(eucl_of_list (map (λx. - f x) xs)::'a) = - eucl_of_list (map f xs)"
  by (auto intro!: euclidean_eqI[where 'a='a] simp: algebra_simps eucl_of_list_inner)

lemma eucl_of_list_map_mult_left[simp]:
  assumes [simp]: "length xs = DIM('a::executable_euclidean_space)"
  shows "(eucl_of_list (map (λx. r * f x) xs)::'a) = r *⇩_R eucl_of_list (map f xs)"
  by (auto intro!: euclidean_eqI[where 'a='a] simp: algebra_simps eucl_of_list_inner)

lemma eucl_of_list_map_mult_right[simp]:
  assumes [simp]: "length xs = DIM('a::executable_euclidean_space)"
  shows "(eucl_of_list (map (λx. f x * r) xs)::'a) = r *⇩_R eucl_of_list (map f xs)"
  by (auto intro!: euclidean_eqI[where 'a='a] simp: algebra_simps eucl_of_list_inner)

lemma eucl_of_list_map_divide_right[simp]:
  assumes [simp]: "length xs = DIM('a::executable_euclidean_space)"
  shows "(eucl_of_list (map (λx. f x / r) xs)::'a) = eucl_of_list (map f xs) /⇩_R r"
  by (auto intro!: euclidean_eqI[where 'a='a] simp: algebra_simps eucl_of_list_inner divide_simps)

lemma eucl_of_list_map_const[simp]:
  assumes [simp]: "length xs = DIM('a::executable_euclidean_space)"
  shows "(eucl_of_list (map (λx. c) xs)::'a) = c *⇩_R One"
  by (auto intro!: euclidean_eqI[where 'a='a] simp: algebra_simps eucl_of_list_inner)

lemma replicate_eq_list_of_eucl_zero: "replicate DIM('a::executable_euclidean_space) 0 = list_of_eucl (0::'a)"
  by (auto intro!: nth_equalityI)

lemma eucl_of_list_append_zeroes[simp]: "eucl_of_list (xs @ replicate n 0) = eucl_of_list xs"
  unfolding eucl_of_list_def
  apply (auto simp: sum_list_sum_nth)
  apply (rule sum.mono_neutral_cong_right)
  by (auto simp: nth_append)

lemma Basis_prodD:
  assumes "(i, j) ∈ Basis"
  shows "i ∈ Basis ∧ j = 0 ∨ i = 0 ∧ j ∈ Basis"
  using assms
  by (auto simp: Basis_prod_def)

lemma eucl_of_list_take_DIM[simp]:
  assumes "d = DIM('b::executable_euclidean_space)"
  shows "(eucl_of_list (take d xs)::'b) = (eucl_of_list xs)"
  by (auto simp: eucl_of_list_inner eucl_of_list_def fst_sum_list sum_list_sum_nth assms dest!: Basis_prodD)

lemma eucl_of_list_eqI:
  assumes "take DIM('a) (xs @ replicate (DIM('a) - length xs) 0) =
    take DIM('a) (ys @ replicate (DIM('a) - length ys) 0)"
  shows "eucl_of_list xs = (eucl_of_list ys::'a::executable_euclidean_space)"
proof -
  have "(eucl_of_list xs::'a) = eucl_of_list (take DIM('a) (xs @ replicate (DIM('a) - length xs) 0))"
    by (simp add: )
  also note assms
  also have "eucl_of_list (take DIM('a) (ys @ replicate (DIM('a) - length ys) 0)) = (eucl_of_list ys::'a)"
    by simp
  finally show ?thesis .
qed

lemma eucl_of_list_replicate_zero[simp]: "eucl_of_list (replicate E 0) = 0"
proof -
  have "eucl_of_list (replicate E 0) = (eucl_of_list (replicate E 0 @ replicate (DIM('a) - E) 0)::'a)"
    by simp
  also have "… = eucl_of_list (replicate DIM('a) 0)"
    apply (rule eucl_of_list_eqI)
    by (auto simp: min_def nth_append intro!: nth_equalityI)
  also have "… = 0"
    by (simp add: replicate_eq_list_of_eucl_zero)
  finally show ?thesis by simp
qed

lemma eucl_of_list_Nil[simp]: "eucl_of_list [] = 0"
  using eucl_of_list_replicate_zero[of 0] by simp


lemma fst_eucl_of_list_prod:
  shows "fst (eucl_of_list xs::'b::executable_euclidean_space  × _) = (eucl_of_list (take DIM('b) xs)::'b)"
  apply (auto simp: eucl_of_list_inner eucl_of_list_def fst_sum_list dest!: Basis_prodD)
  apply (simp add: sum_list_sum_nth)
  apply (rule sum.mono_neutral_cong_right)
  subgoal by simp
  subgoal by auto
  subgoal by (auto simp: Basis_list_prod_def nth_append)
  subgoal by (auto simp: Basis_list_prod_def nth_append)
  done

lemma index_zip_replicate1[simp]: "index (zip (replicate d a) bs) (a, b) = index bs b"
  if "d = length bs"
  using that
  by (induction bs arbitrary: d) auto

lemma index_zip_replicate2[simp]: "index (zip as (replicate d b)) (a, b) = index as a"
  if "d = length as"
  using that
  by (induction as arbitrary: d) auto

lemma index_Basis_list_prod[simp]:
  fixes a::"'a::executable_euclidean_space" and b::"'b::executable_euclidean_space"
  shows "a ∈ Basis ⟹ index Basis_list (a, 0::'b) = index Basis_list a"
    "b ∈ Basis ⟹ index Basis_list (0::'a, b) = DIM('a) + index Basis_list b"
  by (auto simp: Basis_list_prod_def index_append
      in_set_zip zip_replicate index_map_inj dest: spec[where x="index Basis_list a"])

lemma eucl_of_list_eq_takeI:
  assumes "(eucl_of_list (take DIM('a::executable_euclidean_space) xs)::'a) = x"
  shows "eucl_of_list xs = x"
  using eucl_of_list_take_DIM[OF refl, of xs, where 'b='a] assms
  by auto

lemma eucl_of_list_inner_le:
  fixes i::"'a::executable_euclidean_space"
  assumes i: "i ∈ Basis"
  assumes l: "length xs ≥ DIM('a)"
  shows "eucl_of_list xs ∙ i = xs ! (index Basis_list i)"
proof -
  have "(eucl_of_list xs::'a) = eucl_of_list (take DIM('a) (xs @ (replicate (DIM('a) - length xs) 0)))"
    by (rule eucl_of_list_eq_takeI) simp
  also have "… ∙ i = xs ! (index Basis_list i)"
    using assms
    by (subst eucl_of_list_inner) auto
  finally show ?thesis .
qed

lemma eucl_of_list_prod_if:
  assumes "length xs = DIM('a::executable_euclidean_space) + DIM('b::executable_euclidean_space)"
  shows "eucl_of_list xs =
    (eucl_of_list (take DIM('a) xs)::'a, eucl_of_list (drop DIM('a) xs)::'b)"
  apply (rule euclidean_eqI)
  using assms
  apply (auto simp: eucl_of_list_inner dest!: Basis_prodD)
   apply (subst eucl_of_list_inner_le)
  apply (auto simp: Basis_list_prod_def index_append in_set_zip)
  done


lemma snd_eucl_of_list_prod:
  shows "snd (eucl_of_list xs::'b::executable_euclidean_space  × 'c::executable_euclidean_space) =
    (eucl_of_list (drop DIM('b) xs)::'c)"
proof (cases "length xs ≤ DIM('b)")
  case True
  then show ?thesis
    by (auto simp: eucl_of_list_inner eucl_of_list_def snd_sum_list dest!: Basis_prodD)
      (simp add: sum_list_sum_nth Basis_list_prod_def nth_append)
next
  case False
  have "xs = take DIM('b) xs @ drop DIM('b) xs" by simp
  also have "eucl_of_list … = (eucl_of_list (… @ replicate (length xs - DIM('c)) 0)::'b × 'c)"
    by simp
  finally have "eucl_of_list xs = (eucl_of_list (xs @ replicate (DIM('b) + DIM('c) - length xs) 0)::'b × 'c)"
    by simp
  also have "… = eucl_of_list (take (DIM ('b × 'c)) (xs @ replicate (DIM('b) + DIM('c) - length xs) 0))"
    by (simp add: )
  finally have *: "(eucl_of_list xs::'b×'c) = eucl_of_list (take DIM('b × 'c) (xs @ replicate (DIM('b) + DIM('c) - length xs) 0))"
    by simp
  show ?thesis
    apply (subst *)
    apply (subst eucl_of_list_prod_if)
    subgoal by simp
    subgoal
      apply simp
      apply (subst (2) eucl_of_list_take_DIM[OF refl, symmetric])
      apply (subst (2) eucl_of_list_take_DIM[OF refl, symmetric])
      apply (rule arg_cong[where f=eucl_of_list])
      by (auto intro!: nth_equalityI simp: nth_append min_def split: if_splits)
    done
qed

lemma eucl_of_list_prod:
  shows "eucl_of_list xs = (eucl_of_list (take DIM('b) xs)::'b::executable_euclidean_space,
    eucl_of_list (drop DIM('b) xs)::'c::executable_euclidean_space)"
  using snd_eucl_of_list_prod[of xs, where 'b='b and 'c='c]
  using fst_eucl_of_list_prod[of xs, where 'b='b and 'a='c]
  by (auto simp del: snd_eucl_of_list_prod fst_eucl_of_list_prod simp add: prod_eq_iff)

lemma eucl_of_list_real[simp]: "eucl_of_list [x] = (x::real)"
  by (auto simp: eucl_of_list_def Basis_list_real_def)

lemma eucl_of_list_append[simp]:
  assumes "length xs = DIM('i::executable_euclidean_space)"
  assumes "length ys = DIM('j::executable_euclidean_space)"
  shows "eucl_of_list (xs @ ys) = (eucl_of_list xs::'i, eucl_of_list ys::'j)"
  using assms
  by (auto simp: eucl_of_list_prod)

lemma list_allI: "(⋀x. x ∈ set xs ⟹ P x) ⟹ list_all P xs"
  by (auto simp: list_all_iff)

lemma
  concat_map_nthI:
  assumes "⋀x y. x ∈ set xs ⟹ y ∈ set (f x) ⟹ P y"
  assumes "j < length (concat (map f xs))"
  shows "P (concat (map f xs) ! j)"
proof -
  have "list_all P (concat (map f xs))"
    by (rule list_allI) (auto simp: assms)
  then show ?thesis
    by (auto simp: list_all_length assms)
qed

lemma map_nth_append1:
  assumes "length xs = d"
  shows "map ((!) (xs @ ys)) [0..<d] = xs"
  using assms
  by (auto simp: nth_append intro!: nth_equalityI)

lemma map_nth_append2:
  assumes "length ys = d"
  shows "map ((!) (xs @ ys)) [length xs..<length xs + d] = ys"
  using assms
  by (auto simp: intro!: nth_equalityI)

lemma length_map2 [simp]: "length (map2 f xs ys) = min (length xs) (length ys)"
  by simp

lemma map2_nth [simp]: "map2 f xs ys ! n = f (xs ! n) (ys ! n)"
  if "n < length xs" "n < length ys"
  using that by simp

lemma list_of_eucl_add: "list_of_eucl (x + y) = map2 (+) (list_of_eucl x) (list_of_eucl y)"
  by (auto intro!: nth_equalityI simp: inner_simps)

lemma list_of_eucl_inj:
  "list_of_eucl z = list_of_eucl y ⟹ y = z"
  by (metis eucl_of_list_list_of_eucl)

lemma length_Basis_list_pos[simp]: "length Basis_list > 0"
  by (metis length_pos_if_in_set Basis_list SOME_Basis)

lemma Basis_list_nth_nonzero:
  "i < length (Basis_list::'a::executable_euclidean_space list) ⟹ (Basis_list::'a list) ! i ≠ 0"
  by (auto dest!: nth_mem simp: nonzero_Basis)

lemma nth_Basis_list_prod:
  "i < DIM('a) + DIM('b) ⟹ (Basis_list::('a::executable_euclidean_space × 'b::executable_euclidean_space) list) ! i =
    (if i < DIM('a) then (Basis_list ! i, 0) else (0, Basis_list ! (i - DIM('a))))"
  by (auto simp: Basis_list_nth_nonzero prod_eq_iff Basis_list_prod_def nth_append not_less)

lemma eucl_of_list_if:
  assumes [simp]: "length xs = DIM('a::executable_euclidean_space)" "distinct xs"
  shows "eucl_of_list (map (λxa. if xa = x then 1 else 0) (xs::nat list)) =
    (if x ∈ set xs then Basis_list ! index xs x else 0::'a)"
  by (rule euclidean_eqI) (auto simp: eucl_of_list_inner inner_Basis index_nth_id)


lemma take_append_take_minus_idem: "take n XS @ map ((!) XS) [n..<length XS] = XS"
  by (auto intro!: nth_equalityI simp: nth_append min_def)

lemma sum_list_Basis_list[simp]: "sum_list (map f Basis_list) = (∑b∈Basis. f b)"
  by (subst sum_list_distinct_conv_sum_set) (auto simp: Basis_list distinct_Basis_list)

lemma hd_Basis_list[simp]: "hd Basis_list ∈ Basis"
  unfolding Basis_list[symmetric]
  by (rule hd_in_set) (auto simp: set_empty[symmetric])

definition "inner_lv_rel a b = sum_list (map2 (*) a b)"

lemma eucl_of_list_inner_eq: "(eucl_of_list xs::'a) ∙ eucl_of_list ys = inner_lv_rel xs ys"
  if "length xs = DIM('a::executable_euclidean_space)" "length ys = DIM('a)"
  using that
  by (subst euclidean_inner[abs_def], subst sum_list_Basis_list[symmetric])
      (auto simp: eucl_of_list_inner sum_list_sum_nth index_nth_id inner_lv_rel_def)


lemma euclidean_vec_componentwise:
  "(∑(xa::'a::euclidean_space^'b::finite)∈Basis. f xa) = (∑a∈Basis. (∑b::'b∈UNIV. f (axis b a)))"
  apply (auto simp: Basis_vec_def)
  apply (subst sum.swap)
  apply (subst sum.Union_disjoint)
    apply auto
      apply (simp add: axis_eq_axis nonzero_Basis)
   apply (simp add: axis_eq_axis nonzero_Basis)
  apply (subst sum.reindex)
   apply (auto intro!: injI)
  subgoal
    apply (auto simp: set_eq_iff)
    by (metis (full_types) all_not_in_conv inner_axis_axis inner_eq_zero_iff nonempty_Basis nonzero_Basis)
  apply (rule sum.cong[OF refl])
  apply (auto )
  apply (rule sum.reindex_cong[OF _ _ refl])
  apply (auto intro!: inj_onI)
  using axis_eq_axis by blast

lemma vec_nth_inner_scaleR_craziness:
  "f (x $ i ∙ j) *⇩_R j = (∑xa∈UNIV. f (x $ xa ∙ j) *⇩_R axis xa j) $ i"
  by vector (auto simp: axis_def if_distrib scaleR_vec_def sum.delta' cong: if_cong)

instantiation vec :: ("{executable_euclidean_space}", enum) executable_euclidean_space
begin

definition Basis_list_vec :: "('a, 'b) vec list" where
  "Basis_list_vec = concat (map (λn. map (axis n) Basis_list) enum_class.enum)"

definition eucl_down_vec :: "int ⇒ ('a, 'b) vec ⇒ ('a, 'b) vec" where
  "eucl_down_vec p x = (χ i. eucl_down p (x $ i))"

definition eucl_truncate_down_vec :: "nat ⇒ ('a, 'b) vec ⇒ ('a, 'b) vec" where
  "eucl_truncate_down_vec p x = (χ i. eucl_truncate_down p (x $ i))"

definition eucl_truncate_up_vec :: "nat ⇒ ('a, 'b) vec ⇒ ('a, 'b) vec" where
  "eucl_truncate_up_vec p x = (χ i. eucl_truncate_up p (x $ i))"

instance
proof
  show *: "set (Basis_list::('a, 'b) vec list) = Basis"
    unfolding Basis_list_vec_def Basis_vec_def
    apply (auto simp: Basis_list_vec_def vec_eq_iff distinct_map Basis_vec_def
        intro!: distinct_concat inj_onI split: if_splits)
    apply (auto simp: Basis_list_vec_def vec_eq_iff distinct_map enum_distinct
        UNIV_enum[symmetric]
        intro!: distinct_concat inj_onI split: if_splits)
    done
  have "length (Basis_list::('a, 'b) vec list) = CARD('b) * DIM('a)"
    by (auto simp: Basis_list_vec_def length_concat o_def enum_distinct
        sum_list_distinct_conv_sum_set UNIV_enum[symmetric])
  then show "distinct (Basis_list::('a, 'b) vec list)"
    using * by (auto intro!: card_distinct)
qed (simp_all only: vector_cart[symmetric] vec_eq_iff
    eucl_down_vec_def eucl_down_def
    eucl_truncate_down_vec_def eucl_truncate_down_def
    eucl_truncate_up_vec_def eucl_truncate_up_def,
    auto simp: euclidean_vec_componentwise inner_axis Basis_list_vec_def
    vec_nth_inner_scaleR_craziness
    intro!: sum.cong[OF refl])
end


lemma concat_same_lengths_nth:
  assumes "⋀xs. xs ∈ set XS ⟹ length xs = N"
  assumes "i < length XS * N" "N > 0"
  shows "concat XS ! i = XS ! (i div N) ! (i mod N)"
  using assms
  apply (induction XS arbitrary: i)
   apply (auto simp: nth_append nth_Cons split: nat.splits)
   apply (simp add: div_eq_0_iff)
  by (metis Suc_inject div_geq mod_geq)

lemma concat_map_map_index:
  shows "concat (map (λn. map (f n) xs) ys) =
    map (λi. f (ys ! (i div length xs)) (xs ! (i mod length xs))) [0..<length xs * length ys]"
  apply (auto intro!: nth_equalityI simp: length_concat o_def sum_list_sum_nth)
  apply (subst concat_same_lengths_nth)
     apply (auto simp: )
  apply (subst nth_map_upt)
  apply (auto simp: ac_simps)
  apply (subst nth_map)
  apply (metis div_eq_0_iff div_mult2_eq mult.commute mult_0 not_less0)
  apply (subst nth_map)
  subgoal for i
    using gr_implies_not_zero by fastforce
  subgoal by simp
  done

lemma
  sum_list_zip_map:
  assumes "distinct xs"
  shows "(∑(x, y)←zip xs (map g xs). f x y) = (∑x∈set xs. f x (g x))"
  by (force simp add: sum_list_distinct_conv_sum_set assms distinct_zipI1 split_beta'
    in_set_zip in_set_conv_nth inj_on_convol_ident
    intro!: sum.reindex_cong[where l="λx. (x, g x)"])

lemma
  sum_list_zip_map_of:
  assumes "distinct bs"
  assumes "length xs = length bs"
  shows "(∑(x, y)←zip xs bs. f x y) = (∑x∈set bs. f (the (map_of (zip bs xs) x)) x)"
proof -
  have "(∑(x, y)←zip xs bs. f x y) = (∑(y, x)←zip bs xs. f x y)"
    by (subst zip_commute) (auto simp: o_def split_beta')
  also have "… = (∑(x, y)←zip bs (map (the o map_of (zip bs xs)) bs). f y x)"
  proof (rule arg_cong, rule map_cong)
    have "xs = (map (the ∘ map_of (zip bs xs)) bs)"
      using assms
      by (auto intro!: nth_equalityI simp: map_nth map_of_zip_nth)
    then show "zip bs xs = zip bs (map (the ∘ map_of (zip bs xs)) bs)"
      by simp
  qed auto
  also have "… = (∑x∈set bs. f (the (map_of (zip bs xs) x)) x)"
    using assms(1)
    by (subst sum_list_zip_map) (auto simp: o_def)
  finally show ?thesis .
qed



lemma vec_nth_matrix:
  "vec_nth (vec_nth (matrix y) i) j = vec_nth (y (axis j 1)) i"
  unfolding matrix_def by simp

lemma matrix_eqI:
  assumes "⋀x. x ∈ Basis ⟹ A *v x = B *v x"
  shows "(A::real^'n^'n) = B"
  apply vector
  using assms
  apply (auto simp: Basis_vec_def)
  by (metis cart_eq_inner_axis matrix_vector_mul_component)

lemma matrix_columnI:
  assumes "⋀i. column i A = column i B"
  shows "(A::real^'n^'n) = B"
  using assms
  apply vector
  apply (auto simp: column_def)
  apply vector
  by (metis iso_tuple_UNIV_I vec_lambda_inject)

lemma
  vec_nth_Basis:
  fixes x::"real^'n"
  shows "x ∈ Basis ⟹ vec_nth x i = (if x = axis i 1 then 1 else 0)"
  apply (auto simp: Basis_vec_def)
  by (metis cart_eq_inner_axis inner_axis_axis)

lemma vec_nth_eucl_of_list_eq: "length M = CARD('n) ⟹
  vec_nth (eucl_of_list M::real^'n::enum) i = M ! index Basis_list (axis i (1::real))"
  apply (auto simp: eucl_of_list_def)
  apply (subst sum_list_zip_map_of)
   apply (auto intro!: distinct_zipI2 simp: split_beta')
  apply (subst sum.cong[OF refl])
   apply (subst vec_nth_Basis)
    apply (force simp: set_zip)
  apply (rule refl)
  apply (auto simp: if_distrib sum.delta cong: if_cong)
  subgoal
    apply (cases "map_of (zip Basis_list M) (axis i 1::real^'n::enum)")
    subgoal premises prems
    proof -
      have "fst ` set (zip Basis_list M) = (Basis::(real^'n::enum) set)" using prems
        by (auto simp: in_set_zip)
      then show ?thesis
        using prems
        by (subst (asm) map_of_eq_None_iff) simp
    qed
    subgoal for a
      apply (auto simp: in_set_zip)
      subgoal premises prems for n
        by (metis DIM_cart DIM_real index_Basis_list_nth mult.right_neutral prems(2) prems(3))
      done
    done
  done

lemma index_Basis_list_axis1: "index Basis_list (axis i (1::real)) = index enum_class.enum i"
  apply (auto simp: Basis_list_vec_def Basis_list_real_def )
  apply (subst index_map_inj)
  by (auto intro!: injI simp: axis_eq_axis)

lemma vec_nth_eq_list_of_eucl1:
  "(vec_nth (M::real^'n::enum) i) = list_of_eucl M ! (index enum_class.enum i)"
  apply (subst eucl_of_list_list_of_eucl[of M, symmetric])
  apply (subst vec_nth_eucl_of_list_eq)
  unfolding index_Basis_list_axis1
  by auto

lemma enum_3[simp]: "(enum_class.enum::3 list) = [0, 1, 2]"
  by code_simp+

lemma three_eq_zero: "(3::3) = 0" by simp

lemma forall_3': "(∀i::3. P i) ⟷ P 0 ∧ P 1 ∧ P 2"
  using forall_3 three_eq_zero by auto

lemma euclidean_eq_list_of_euclI: "x = y" if "list_of_eucl x = list_of_eucl y"
  using that
  by (metis eucl_of_list_list_of_eucl)

lemma axis_one_neq_zero[simp]: "axis xa (1::'a::zero_neq_one) ≠ 0"
  by (auto simp: axis_def vec_eq_iff)


lemma eucl_of_list_vec_nth3[simp]:
  "(eucl_of_list [g, h, i]::real^3) $ 0 = g"
  "(eucl_of_list [g, h, i]::real^3) $ 1 = h"
  "(eucl_of_list [g, h, i]::real^3) $ 2 = i"
  "(eucl_of_list [g, h, i]::real^3) $ 3 = g"
  by (auto simp: cart_eq_inner_axis eucl_of_list_inner vec_nth_eq_list_of_eucl1 index_Basis_list_axis1)

type_synonym R3 = "real*real*real"

lemma Basis_list_R3: "Basis_list = [(1,0,0), (0, 1, 0), (0, 0, 1)::R3]"
  by (auto simp: Basis_list_prod_def Basis_list_real_def zero_prod_def)

lemma Basis_list_vec3: "Basis_list = [axis 0 1::real^3, axis 1 1, axis 2 1]"
  by (auto simp: Basis_list_vec_def Basis_list_real_def)

lemma eucl_of_list3[simp]: "eucl_of_list [a, b, c] = (a, b, c)"
  by (auto simp: eucl_of_list_inner Basis_list_vec_def zero_prod_def
      Basis_prod_def Basis_list_vec3 Basis_list_R3
      intro!: euclidean_eqI[where 'a=R3])


subsection ‹Bounded Linear Functions›

subsection ‹bounded linear functions›

locale blinfun_syntax
begin
no_notation vec_nth (infixl "$" 90)
notation blinfun_apply (infixl "$" 999)
end

lemma bounded_linear_via_derivative:
  fixes f::"'a::real_normed_vector ⇒ 'b::euclidean_space ⇒⇩_L 'c::real_normed_vector" ― ‹TODO: generalize?›
  assumes "⋀i. ((λx. blinfun_apply (f x) i) has_derivative (λx. f' y x i)) (at y)"
  shows "bounded_linear (f' y x)"
proof -
  interpret linear "f' y x"
  proof (unfold_locales, goal_cases)
    case (1 v w)
    from has_derivative_unique[OF assms[of "v + w", unfolded blinfun.bilinear_simps]
      has_derivative_add[OF assms[of v] assms[of w]], THEN fun_cong, of x]
    show ?case .
  next
    case (2 r v)
    from has_derivative_unique[OF assms[of "r *⇩_R v", unfolded blinfun.bilinear_simps]
      has_derivative_scaleR_right[OF assms[of v], of r], THEN fun_cong, of x]
    show ?case .
  qed
  let ?bnd = "∑i∈Basis. norm (f' y x i)"
  {
    fix v
    have "f' y x v = (∑i∈Basis. (v ∙ i) *⇩_R f' y x i)"
      by (subst euclidean_representation[symmetric]) (simp add: sum scaleR)
    also have "norm … ≤ norm v * ?bnd"
      by (auto intro!: order.trans[OF norm_sum] sum_mono mult_right_mono
        simp: sum_distrib_left Basis_le_norm)
    finally have "norm (f' y x v) ≤ norm v * ?bnd" .
  }
  then show ?thesis by unfold_locales auto
qed

definition blinfun_scaleR::"('a::real_normed_vector ⇒⇩_L real) ⇒ 'b::real_normed_vector ⇒ ('a ⇒⇩_L 'b)"
  where "blinfun_scaleR a b = blinfun_scaleR_left b o⇩_L a"

lemma blinfun_scaleR_transfer[transfer_rule]:
  "rel_fun (pcr_blinfun (=) (=)) (rel_fun (=) (pcr_blinfun (=) (=)))
    (λa b c. a c *⇩_R b) blinfun_scaleR"
  by (auto simp: blinfun_scaleR_def rel_fun_def pcr_blinfun_def cr_blinfun_def OO_def)

lemma blinfun_scaleR_rep_eq[simp]:
  "blinfun_scaleR a b c = a c *⇩_R b"
  by (simp add: blinfun_scaleR_def)

lemma bounded_linear_blinfun_scaleR: "bounded_linear (blinfun_scaleR a)"
  unfolding blinfun_scaleR_def[abs_def]
  by (auto intro!: bounded_linear_intros)

lemma blinfun_scaleR_has_derivative[derivative_intros]:
  assumes "(f has_derivative f') (at x within s)"
  shows "((λx. blinfun_scaleR a (f x)) has_derivative (λx. blinfun_scaleR a (f' x))) (at x within s)"
  using bounded_linear_blinfun_scaleR assms
  by (rule bounded_linear.has_derivative)

lemma blinfun_componentwise:
  fixes f::"'a::real_normed_vector ⇒ 'b::euclidean_space ⇒⇩_L 'c::real_normed_vector"
  shows "f = (λx. ∑i∈Basis. blinfun_scaleR (blinfun_inner_left i) (f x i))"
  by (auto intro!: blinfun_eqI
    simp: blinfun.sum_left euclidean_representation blinfun.scaleR_right[symmetric]
      blinfun.sum_right[symmetric])

lemma
  blinfun_has_derivative_componentwiseI:
  fixes f::"'a::real_normed_vector ⇒ 'b::euclidean_space ⇒⇩_L 'c::real_normed_vector"
  assumes "⋀i. i ∈ Basis ⟹ ((λx. f x i) has_derivative blinfun_apply (f' i)) (at x)"
  shows "(f has_derivative (λx. ∑i∈Basis. blinfun_scaleR (blinfun_inner_left i) (f' i x))) (at x)"
  by (subst blinfun_componentwise) (force intro: derivative_eq_intros assms simp: blinfun.bilinear_simps)

lemma
  has_derivative_BlinfunI:
  fixes f::"'a::real_normed_vector ⇒ 'b::euclidean_space ⇒⇩_L 'c::real_normed_vector"
  assumes "⋀i. ((λx. f x i) has_derivative (λx. f' y x i)) (at y)"
  shows "(f has_derivative (λx. Blinfun (f' y x))) (at y)"
proof -
  have 1: "f = (λx. ∑i∈Basis. blinfun_scaleR (blinfun_inner_left i) (f x i))"
    by (rule blinfun_componentwise)
  moreover have 2: "(… has_derivative (λx. ∑i∈Basis. blinfun_scaleR (blinfun_inner_left i) (f' y x i))) (at y)"
    by (force intro: assms derivative_eq_intros)
  moreover
  interpret f': bounded_linear "f' y x" for x
    by (rule bounded_linear_via_derivative) (rule assms)
  have 3: "(∑i∈Basis. blinfun_scaleR (blinfun_inner_left i) (f' y x i)) i = f' y x i" for x i
    by (auto simp: if_distrib if_distribR blinfun.bilinear_simps
      f'.scaleR[symmetric] f'.sum[symmetric] euclidean_representation
      intro!: blinfun_euclidean_eqI)
  have 4: "blinfun_apply (Blinfun (f' y x)) = f' y x" for x
    apply (subst bounded_linear_Blinfun_apply)
    subgoal by unfold_locales
    subgoal by simp
    done
  show ?thesis
    apply (subst 1)
    apply (rule 2[THEN has_derivative_eq_rhs])
    apply (rule ext)
    apply (rule blinfun_eqI)
    apply (subst 3)
    apply (subst 4)
    apply (rule refl)
    done
qed

lemma
  has_derivative_Blinfun:
  assumes "(f has_derivative f') F"
  shows "(f has_derivative Blinfun f') F"
  using assms
  by (subst bounded_linear_Blinfun_apply) auto

lift_definition flip_blinfun::
  "('a::real_normed_vector ⇒⇩_L 'b::real_normed_vector ⇒⇩_L 'c::real_normed_vector) ⇒ 'b ⇒⇩_L 'a ⇒⇩_L 'c" is
  "λf x y. f y x"
  using bounded_bilinear.bounded_linear_left bounded_bilinear.bounded_linear_right bounded_bilinear.flip
  by auto

lemma flip_blinfun_apply[simp]: "flip_blinfun f a b = f b a"
  by transfer simp

lemma le_norm_blinfun:
  shows "norm (blinfun_apply f x) / norm x ≤ norm f"
  by transfer (rule le_onorm)

lemma norm_flip_blinfun[simp]: "norm (flip_blinfun x) = norm x" (is "?l = ?r")
proof (rule antisym)
  from order_trans[OF norm_blinfun, OF mult_right_mono, OF norm_blinfun, OF norm_ge_zero, of x]
  show "?l ≤ ?r"
    by (auto intro!: norm_blinfun_bound simp: ac_simps)
  have "norm (x a b) ≤ norm (flip_blinfun x) * norm a * norm b" for a b
  proof -
    have "norm (x a b) / norm a ≤ norm (flip_blinfun x b)"
      by (rule order_trans[OF _ le_norm_blinfun]) auto
    also have "… ≤ norm (flip_blinfun x) * norm b"
      by (rule norm_blinfun)
    finally show ?thesis
      by (auto simp add: divide_simps blinfun.bilinear_simps algebra_simps split: if_split_asm)
  qed
  then show "?r ≤ ?l"
    by (auto intro!: norm_blinfun_bound)
qed

lemma bounded_linear_flip_blinfun[bounded_linear]: "bounded_linear flip_blinfun"
  by unfold_locales (auto simp: blinfun.bilinear_simps intro!: blinfun_eqI exI[where x=1])

lemma dist_swap2_swap2[simp]: "dist (flip_blinfun f) (flip_blinfun g) = dist f g"
  by (metis (no_types) bounded_linear_flip_blinfun dist_blinfun_def linear_simps(2)
    norm_flip_blinfun)


context includes blinfun.lifting begin

lift_definition blinfun_of_vmatrix::"(real^'m^'n) ⇒ ((real^('m::finite)) ⇒⇩_L (real^('n::finite)))" is
  "matrix_vector_mult:: ((real, 'm) vec, 'n) vec ⇒ ((real, 'm) vec ⇒ (real, 'n) vec)"
  unfolding linear_linear
  by (rule matrix_vector_mul_linear)

lemma matrix_blinfun_of_vmatrix[simp]: "matrix (blinfun_of_vmatrix M) = M"
  apply vector
  apply (auto simp: matrix_def)
  apply transfer
  by (metis cart_eq_inner_axis matrix_vector_mul_component)

end

lemma blinfun_apply_componentwise:
  "B = (∑i∈Basis. blinfun_scaleR (blinfun_inner_left i) (blinfun_apply B i))"
  using blinfun_componentwise[of "λx. B", unfolded fun_eq_iff]
  by blast

lemma blinfun_apply_eq_sum:
  assumes [simp]: "length v = CARD('n)"
  shows "blinfun_apply (B::(real^'n::enum)⇒⇩_L(real^'m::enum)) (eucl_of_list v) =
    (∑i<CARD('m). ∑j<CARD('n). ((B (Basis_list ! j) ∙ Basis_list ! i) * v ! j) *⇩_R (Basis_list ! i))"
  apply (subst blinfun_apply_componentwise[of B])
  apply (auto intro!: euclidean_eqI[where 'a="(real,'m) vec"]
      simp: blinfun.bilinear_simps eucl_of_list_inner inner_sum_left inner_Basis if_distrib
        sum_Basis_sum_nth_Basis_list nth_eq_iff_index if_distribR
        cong: if_cong)
  apply (subst sum.swap)
  by (auto simp: sum.delta algebra_simps)

lemma in_square_lemma[intro, simp]: "x * C + y < D * C" if "x < D" "y < C" for x::nat
proof -
  have "x * C + y < (D - 1) * C + C"
    apply (rule add_le_less_mono)
     apply (rule mult_right_mono)
    using that
    by auto
  also have "… ≤ D * C"
    using that
    by (auto simp: algebra_simps)
  finally show ?thesis .
qed

lemma less_square_imp_div_less[intro, simp]: "i < E * D ⟹  i div E < D" for i::nat
  by (metis div_eq_0_iff div_mult2_eq gr_implies_not0 mult_not_zero)

lemma in_square_lemma'[intro, simp]: "i < L ⟹ n < N ⟹ i * N + n < N * L" for i n::nat
  by (metis in_square_lemma mult.commute)

lemma
  distinct_nth_eq_iff:
  "distinct xs ⟹ x < length xs ⟹ y < length xs ⟹ xs ! x = xs ! y ⟷ x = y"
  by (drule inj_on_nth[where I="{..<length xs}"]) (auto simp: inj_onD)

lemma index_Basis_list_axis2:
  "index Basis_list (axis (j::'j::enum) (axis (i::'i::enum) (1::real))) =
    (index enum_class.enum j) * CARD('i) + index enum_class.enum i"
  apply (auto simp: Basis_list_vec_def Basis_list_real_def o_def)
  apply (subst concat_map_map_index)
  unfolding card_UNIV_length_enum[symmetric]
  subgoal
  proof -
    have index_less_cardi: "index enum_class.enum k < CARD('i)" for k::'i
      by (rule index_less) (auto simp: enum_UNIV card_UNIV_length_enum)
    have index_less_cardj: "index enum_class.enum k < CARD('j)" for k::'j
      by (rule index_less) (auto simp: enum_UNIV card_UNIV_length_enum)
    have *: "axis j (axis i 1) =
      (λi. axis (enum_class.enum ! (i div CARD('i)))
                      (axis (enum_class.enum ! (i mod CARD('i))) 1))
      ((index enum_class.enum j) * CARD('i) + index enum_class.enum i)"
      by (auto simp: index_less_cardi enum_UNIV)
    note less=in_square_lemma[OF index_less_cardj index_less_cardi, of j i]
    show ?thesis
      apply (subst *)
      apply (subst index_map_inj_on[where S="{..<CARD('j)*CARD('i)}"])
      subgoal
        apply (auto intro!: inj_onI simp: axis_eq_axis )
         apply (subst (asm) distinct_nth_eq_iff)
        apply (auto simp: enum_distinct card_UNIV_length_enum)
        subgoal for x y
          using gr_implies_not0 by fastforce
        subgoal for x y
          using gr_implies_not0 by fastforce
        subgoal for x y
          apply (drule inj_onD[OF inj_on_nth[OF enum_distinct[where 'a='j], where I = "{..<CARD('j)}"], rotated])
             apply (auto simp: card_UNIV_length_enum mult.commute)
          subgoal
            by (metis mod_mult_div_eq)
          done
        done
      subgoal using less by (auto simp: )
      subgoal by (auto simp: card_UNIV_length_enum ac_simps)
      subgoal apply (subst index_upt)
        subgoal using less by auto
        subgoal using less by (auto simp: ac_simps)
        subgoal using less by auto
        done
      done
  qed
  done

lemma
  vec_nth_Basis2:
  fixes x::"real^'n^'m"
  shows "x ∈ Basis ⟹ vec_nth (vec_nth x i) j = ((if x = axis i (axis j 1) then 1 else 0))"
  by (auto simp: Basis_vec_def axis_def)

lemma vec_nth_eucl_of_list_eq2: "length M = CARD('n) * CARD('m) ⟹
  vec_nth (vec_nth (eucl_of_list M::real^'n::enum^'m::enum) i) j = M ! index Basis_list (axis i (axis j (1::real)))"
  apply (auto simp: eucl_of_list_def)
  apply (subst sum_list_zip_map_of)
   apply (auto intro!: distinct_zipI2 simp: split_beta')
  apply (subst sum.cong[OF refl])
   apply (subst vec_nth_Basis2)
    apply (force simp: set_zip)
  apply (rule refl)
  apply (auto simp: if_distrib sum.delta cong: if_cong)
  subgoal
    apply (cases "map_of (zip Basis_list M) (axis i (axis j 1)::real^'n::enum^'m::enum)")
    subgoal premises prems
    proof -
      have "fst ` set (zip Basis_list M) = (Basis::(real^'n::enum^'m::enum) set)" using prems
        by (auto simp: in_set_zip)
      then show ?thesis
        using prems
        by (subst (asm) map_of_eq_None_iff) auto
    qed
    subgoal for a
      apply (auto simp: in_set_zip)
      subgoal premises prems for n
      proof -
        have "n < card (Basis::(real^'n::_^'m::_) set)"
          by (simp add: prems(4))
        then show ?thesis
          by (metis index_Basis_list_nth prems(2))
      qed
      done
    done
  done

lemma vec_nth_eq_list_of_eucl2:
  "vec_nth (vec_nth (M::real^'n::enum^'m::enum) i) j =
    list_of_eucl M ! (index enum_class.enum i * CARD('n) + index enum_class.enum j)"
  apply (subst eucl_of_list_list_of_eucl[of M, symmetric])
  apply (subst vec_nth_eucl_of_list_eq2)
  unfolding index_Basis_list_axis2
  by auto

theorem
  eucl_of_list_matrix_vector_mult_eq_sum_nth_Basis_list:
  assumes "length M = CARD('n) * CARD('m)"
  assumes "length v = CARD('n)"
  shows "(eucl_of_list M::real^'n::enum^'m::enum) *v eucl_of_list v =
    (∑i<CARD('m).
      (∑j<CARD('n). M ! (i * CARD('n) + j) * v ! j) *⇩_R Basis_list ! i)"
  apply (vector matrix_vector_mult_def)
  apply (auto simp: )
  apply (subst vec_nth_eucl_of_list_eq2)
   apply (auto simp: assms)
  apply (subst vec_nth_eucl_of_list_eq)
   apply (auto simp: assms index_Basis_list_axis2 index_Basis_list_axis1 vec_nth_Basis sum.delta
      nth_eq_iff_index
      if_distrib cong: if_cong)
  subgoal for i
    apply (rule sum.reindex_cong[where l="nth enum_class.enum"])
      apply (auto simp: enum_distinct card_UNIV_length_enum distinct_nth_eq_iff intro!: inj_onI)
     apply (rule image_eqI[OF ])
      apply (rule nth_index[symmetric])
      apply (auto simp: enum_UNIV)
    by (auto simp: algebra_simps enum_UNIV enum_distinct index_nth_id)
  subgoal for i
    using index_less[of i "enum_class.enum" "CARD('n)"]
    by (auto simp: enum_UNIV card_UNIV_length_enum)
  done

lemma index_enum_less[intro, simp]: "index enum_class.enum (i::'n::enum) < CARD('n)"
  by (auto intro!: index_less simp: enum_UNIV card_UNIV_length_enum)

lemmas [intro, simp] = enum_distinct
lemmas [simp] = card_UNIV_length_enum[symmetric] enum_UNIV

lemma sum_index_enum_eq:
  "(∑(k::'n::enum)∈UNIV. f (index enum_class.enum k)) = (∑i<CARD('n). f i)"
  by (rule sum.reindex_cong[where l="nth enum_class.enum"])
    (force intro!: inj_onI simp: distinct_nth_eq_iff index_nth_id)+

end

Theory Affine_Form

section ‹Affine Form›
theory Affine_Form
imports
  "HOL-Analysis.Multivariate_Analysis"
  "HOL-Library.Permutation"
  Affine_Arithmetic_Auxiliarities
  Executable_Euclidean_Space
begin

subsection ‹Auxiliary developments›

lemma sum_list_mono:
  fixes xs ys::"'a::ordered_ab_group_add list"
  shows
    "length xs = length ys ⟹ (⋀x y. (x, y) ∈ set (zip xs ys) ⟹ x ≤ y) ⟹
      sum_list xs ≤ sum_list ys"
  by (induct xs ys rule: list_induct2) (auto simp: algebra_simps intro: add_mono)

lemma
  fixes xs::"'a::ordered_comm_monoid_add list"
  shows sum_list_nonneg: "(⋀x. x ∈ set xs ⟹ x ≥ 0) ⟹ sum_list xs ≥ 0"
  by (induct xs) (auto intro!: add_nonneg_nonneg)

lemma map_filter:
  "map f (filter (λx. P (f x)) xs) = filter P (map f xs)"
  by (induct xs) simp_all

lemma
  map_of_zip_upto2_length_eq_nth:
  assumes "distinct B"
  assumes "i < length B"
  shows "(map_of (zip B [0..<length B]) (B ! i)) = Some i"
proof -
  have "length [0..<length B] = length B"
    by simp
  from map_of_zip_is_Some[OF this, of i] assms
  have "map_of (zip B [0..<length B]) (B ! i) = Some i"
    using assms by (auto simp: in_set_zip)
  thus ?thesis by simp
qed

lemma distinct_map_fst_snd_eqD:
  "distinct (map fst xs) ⟹ (i, a) ∈ set xs ⟹ (i, b) ∈ set xs ⟹ a = b"
  by (metis (lifting) map_of_is_SomeI option.inject)

lemma length_filter_snd_zip:
  "length ys = length xs ⟹ length (filter (p ∘ snd) (zip ys xs)) = length (filter p xs)"
  by (induct ys xs rule: list_induct2) (auto )

lemma filter_snd_nth:
  "length ys = length xs ⟹ n < length (filter p xs) ⟹
    snd (filter (p ∘ snd) (zip ys xs) ! n) = filter p xs ! n"
  by (induct ys xs arbitrary: n rule: list_induct2) (auto simp: o_def nth_Cons split: nat.split)

lemma distinct_map_snd_fst_eqD:
  "distinct (map snd xs) ⟹ (i, a) ∈ set xs ⟹ (j, a) ∈ set xs ⟹ i = j"
  by (metis Pair_inject inj_on_contraD snd_conv distinct_map)

lemma map_of_mapk_inj_on_SomeI:
  "inj_on f (fst ` (set t)) ⟹ map_of t k = Some x ⟹
    map_of (map (case_prod (λk. Pair (f k))) t) (f k) = Some x"
  by (induct t) (auto simp add: inj_on_def dest!: map_of_SomeD split: if_split_asm)

lemma map_abs_nonneg[simp]:
  fixes xs::"'a::ordered_ab_group_add_abs list"
  shows "list_all (λx. x ≥ 0) xs ⟹ map abs xs = xs"
  by (induct xs) auto

lemma the_inv_into_image_eq: "inj_on f A ⟹ Y ⊆ f ` A ⟹ the_inv_into A f ` Y = f -` Y ∩ A"
  using f_the_inv_into_f the_inv_into_f_f[where f = f and A = A]
  by force

lemma image_fst_zip: "length ys = length xs ⟹ fst ` set (zip ys xs) = set ys"
  by (metis dom_map_of_conv_image_fst dom_map_of_zip)

lemma inj_on_fst_set_zip_distinct[simp]:
  "distinct xs ⟹ length xs = length ys ⟹ inj_on fst (set (zip xs ys))"
  by (force simp add: in_set_zip distinct_conv_nth intro!: inj_onI)

lemma mem_greaterThanLessThan_absI:
  fixes x::real
  assumes "abs x < 1"
  shows "x ∈ {-1 <..< 1}"
  using assms by (auto simp: abs_real_def split: if_split_asm)

lemma minus_one_less_divideI: "b > 0 ⟹ -b < a ⟹ -1 < a / (b::real)"
  by (auto simp: field_simps)

lemma divide_less_oneI: "b > 0 ⟹ b > a ⟹ a / (b::real) < 1"
  by (auto simp: field_simps)

lemma closed_segment_real:
  fixes a b::real
  shows "closed_segment a b = (if a ≤ b then {a .. b} else {b .. a})" (is "_ = ?if")
proof safe
  fix x assume "x ∈ closed_segment a b"
  from segment_bound[OF this]
  show "x ∈ ?if" by (auto simp: abs_real_def split: if_split_asm)
next
  fix x
  assume "x ∈ ?if"
  thus "x ∈ closed_segment a b"
    by (auto simp: closed_segment_def intro!: exI[where x="(x - a)/(b - a)"]
      simp: divide_simps algebra_simps)
qed


subsection ‹Partial Deviations›

typedef (overloaded) 'a pdevs = "{x::nat ⇒ 'a::zero. finite {i. x i ≠ 0}}"
  ― ‹TODO: unify with polynomials›
  morphisms pdevs_apply Abs_pdev
  by (auto intro!: exI[where x="λx. 0"])

setup_lifting type_definition_pdevs

lemma pdevs_eqI: "(⋀i. pdevs_apply x i = pdevs_apply y i) ⟹ x = y"
  by transfer auto

definition pdevs_val :: "(nat ⇒ real) ⇒ 'a::real_normed_vector pdevs ⇒ 'a"
  where "pdevs_val e x = (∑i. e i *⇩_R pdevs_apply x i)"

definition valuate:: "((nat ⇒ real) ⇒ 'a) ⇒ 'a set"
  where "valuate x = x ` (UNIV → {-1 .. 1})"

lemma valuate_ex: "x ∈ valuate f ⟷ (∃e. (∀i. e i ∈ {-1 .. 1}) ∧ x = f e)"
  unfolding valuate_def
  by (auto simp add: valuate_def Pi_iff) blast

instantiation pdevs :: (equal) equal
begin

definition equal_pdevs::"'a pdevs ⇒ 'a pdevs ⇒ bool"
  where "equal_pdevs a b ⟷ a = b"

instance proof qed (simp add: equal_pdevs_def)
end


subsection ‹Affine Forms›

text ‹The data structure of affine forms represents particular sets, zonotopes›

type_synonym 'a aform = "'a × 'a pdevs"


subsection ‹Evaluation, Range, Joint Range›

definition aform_val :: "(nat ⇒ real) ⇒ 'a::real_normed_vector aform ⇒ 'a"
  where "aform_val e X = fst X + pdevs_val e (snd X)"

definition Affine ::
    "'a::real_normed_vector aform ⇒ 'a set"
  where "Affine X = valuate (λe. aform_val e X)"

definition Joints ::
    "'a::real_normed_vector aform list ⇒ 'a list set"
  where "Joints XS = valuate (λe. map (aform_val e) XS)"

lemma Joints_nthE:
  assumes "zs ∈ Joints ZS"
  obtains e where
    "⋀i. i < length zs ⟹ zs ! i = aform_val e (ZS ! i)"
    "⋀i. e i ∈ {-1..1}"
  using assms
  by atomize_elim (auto simp: Joints_def Pi_iff valuate_ex)

lemma Joints_mapE:
  assumes "ys ∈ Joints YS"
  obtains e where
    "ys = map (λx. aform_val e x) YS"
    "⋀i. e i ∈ {-1 .. 1}"
  using assms
  by (force simp: Joints_def valuate_def)

lemma
  zipped_subset_mapped_Elem:
  assumes "xs = map (aform_val e) XS"
  assumes e: "⋀i. e i ∈ {-1 .. 1}"
  assumes [simp]: "length xs = length XS"
  assumes [simp]: "length ys = length YS"
  assumes "set (zip ys YS) ⊆ set (zip xs XS)"
  shows "ys = map (aform_val e) YS"
proof -
  from assms have ys: "⋀i. i < length xs ⟹ xs ! i = aform_val e (XS ! i)"
    by auto
  from assms have set_eq: "{(ys ! i, YS ! i) |i. i < length ys ∧ i < length YS} ⊆
    {(xs ! i, XS ! i) |i. i < length xs ∧ i < length XS}"
    using assms(2)
    by (auto simp: set_zip)
  hence "∀i<length YS. ∃j<length XS. ys ! i = xs ! j ∧ YS ! i = XS ! j"
    by auto
  then obtain j where j: "⋀i. i < length YS ⟹ ys ! i = xs ! (j i)"
    "⋀i. i < length YS ⟹ YS ! i = XS ! (j i)"
    "⋀i. i < length YS ⟹ j i < length XS"
    by metis
  show ?thesis
    using assms
    by (auto simp: Joints_def j ys intro!: exI[where x=e] nth_equalityI)
qed

lemma Joints_set_zip_subset:
  assumes "xs ∈ Joints XS"
  assumes "length xs = length XS"
  assumes "length ys = length YS"
  assumes "set (zip ys YS) ⊆ set (zip xs XS)"
  shows "ys ∈ Joints YS"
proof -
  from Joints_mapE assms obtain e where
    ys: "xs = map (λx. aform_val e x) XS"
    and e: "⋀i. e i ∈ {-1 .. 1}"
    by blast
  show "ys ∈ Joints YS"
    using e zipped_subset_mapped_Elem[OF ys e assms(2-4)]
    by (auto simp: Joints_def valuate_def intro!: exI[where x=e])
qed

lemma Joints_set_zip:
  assumes "ys ∈ Joints YS"
  assumes "length xs = length XS"
  assumes "length YS = length XS"
  assumes sets_eq: "set (zip xs XS) = set (zip ys YS)"
  shows "xs ∈ Joints XS"
proof -
  from assms have "length ys = length YS"
    by (auto simp: Joints_def valuate_def)
  from assms(1) this assms(2) show ?thesis
    by (rule Joints_set_zip_subset) (simp add: assms)
qed

definition Joints2 ::
    "'a::real_normed_vector aform list ⇒'b::real_normed_vector aform ⇒ ('a list × 'b) set"
  where "Joints2 XS Y = valuate (λe. (map (aform_val e) XS, aform_val e Y))"

lemma Joints2E:
  assumes "zs_y ∈ Joints2 ZS Y"
  obtains e where
    "⋀i. i < length (fst zs_y) ⟹ (fst zs_y) ! i = aform_val e (ZS ! i)"
    "snd (zs_y) = aform_val e Y"
    "⋀i. e i ∈ {-1..1}"
  using assms
  by atomize_elim (auto simp: Joints2_def Pi_iff valuate_ex)

lemma nth_in_AffineI:
  assumes "xs ∈ Joints XS"
  assumes "i < length XS"
  shows "xs ! i ∈ Affine (XS ! i)"
  using assms by (force simp: Affine_def Joints_def valuate_def)

lemma Cons_nth_in_Joints1:
  assumes "xs ∈ Joints XS"
  assumes "i < length XS"
  shows "((xs ! i) # xs) ∈ Joints ((XS ! i) # XS)"
  using assms by (force simp: Joints_def valuate_def)

lemma Cons_nth_in_Joints2:
  assumes "xs ∈ Joints XS"
  assumes "i < length XS"
  assumes "j < length XS"
  shows "((xs ! i) #(xs ! j) # xs) ∈ Joints ((XS ! i)#(XS ! j) # XS)"
  using assms by (force simp: Joints_def valuate_def)

lemma Joints_swap:
  "x#y#xs∈Joints (X#Y#XS) ⟷ y#x#xs ∈ Joints (Y#X#XS)"
  by (force simp: Joints_def valuate_def)

lemma Joints_swap_Cons_append:
  "length xs = length XS ⟹ x#ys@xs∈Joints (X#YS@XS) ⟷ ys@x#xs ∈ Joints (YS@X#XS)"
  by (auto simp: Joints_def valuate_def)

lemma Joints_ConsD:
  "x#xs∈Joints (X#XS) ⟹ xs ∈ Joints XS"
  by (force simp: Joints_def valuate_def)

lemma Joints_appendD1:
  "ys@xs∈Joints (YS@XS) ⟹ length xs = length XS ⟹ xs ∈ Joints XS"
  by (force simp: Joints_def valuate_def)

lemma Joints_appendD2:
  "ys@xs∈Joints (YS@XS) ⟹ length ys = length YS ⟹ ys ∈ Joints YS"
  by (force simp: Joints_def valuate_def)

lemma Joints_imp_length_eq: "xs ∈ Joints XS ⟹ length xs = length XS"
  by (auto simp: Joints_def valuate_def)

lemma Joints_rotate[simp]: "xs@[x] ∈ Joints (XS @[X]) ⟷ x#xs ∈ Joints (X#XS)"
  by (auto simp: Joints_def valuate_def)


subsection ‹Domain›

definition "pdevs_domain x = {i. pdevs_apply x i ≠ 0}"

lemma finite_pdevs_domain[intro, simp]: "finite (pdevs_domain x)"
  unfolding pdevs_domain_def by transfer

lemma in_pdevs_domain[simp]: "i ∈ pdevs_domain x ⟷ pdevs_apply x i ≠ 0"
  by (auto simp: pdevs_domain_def)


subsection ‹Least Fresh Index›

definition degree::"'a::real_vector pdevs ⇒ nat"
  where "degree x = (LEAST i. ∀j≥i. pdevs_apply x j = 0)"

lemma degree[rule_format, intro, simp]:
  shows "∀j≥degree x. pdevs_apply x j = 0"
  unfolding degree_def
proof (rule LeastI_ex)
  have "⋀j. j > Max (pdevs_domain x) ⟹ j ∉ (pdevs_domain x)"
    by (metis Max_less_iff all_not_in_conv less_irrefl_nat finite_pdevs_domain)
  then show "∃xa. ∀j≥xa. pdevs_apply x j = 0"
    by (auto intro!: exI[where x="Max (pdevs_domain x) + 1"])
qed

lemma degree_le:
  assumes d: "∀j ≥ d. pdevs_apply x j = 0"
  shows "degree x ≤ d"
  unfolding degree_def
  by (rule Least_le) (rule d)

lemma degree_gt: "pdevs_apply x j ≠ 0 ⟹ degree x > j"
  by auto

lemma pdevs_val_pdevs_domain: "pdevs_val e X = (∑i∈pdevs_domain X. e i *⇩_R pdevs_apply X i)"
  by (auto simp: pdevs_val_def intro!: suminf_finite)

lemma pdevs_val_sum_le: "degree X ≤ d ⟹ pdevs_val e X = (∑i < d. e i *⇩_R pdevs_apply X i)"
  by (force intro!: degree_gt sum.mono_neutral_cong_left simp: pdevs_val_pdevs_domain)

lemmas pdevs_val_sum = pdevs_val_sum_le[OF order_refl]

lemma pdevs_val_zero[simp]: "pdevs_val (λ_. 0) x = 0"
  by (auto simp: pdevs_val_sum)

lemma degree_eqI:
  assumes "pdevs_apply x d ≠ 0"
  assumes "⋀j. j > d ⟹ pdevs_apply x j = 0"
  shows "degree x = Suc d"
  unfolding eq_iff
  by (auto intro!: degree_gt degree_le assms simp: Suc_le_eq)

lemma finite_degree_nonzero[intro, simp]: "finite {i. pdevs_apply x i ≠ 0}"
  by transfer (auto simp: vimage_def Collect_neg_eq)

lemma degree_eq_Suc_max:
  "degree x = (if (∀i. pdevs_apply x i = 0) then 0 else Suc (Max {i. pdevs_apply x i ≠ 0}))"
proof -
  {
    assume "⋀i. pdevs_apply x i = 0"
    hence ?thesis
      by auto (metis degree_le le_0_eq)
  } moreover {
    fix i assume "pdevs_apply x i ≠ 0"
    hence ?thesis
      using Max_in[OF finite_degree_nonzero, of x]
      by (auto intro!: degree_eqI) (metis Max.coboundedI[OF finite_degree_nonzero] in_pdevs_domain
        le_eq_less_or_eq less_asym pdevs_domain_def)
  } ultimately show ?thesis
    by blast
qed

lemma pdevs_val_degree_cong:
  assumes "b = d"
  assumes "⋀i. i < degree b ⟹ a i = c i"
  shows "pdevs_val a b = pdevs_val c d"
  using assms
  by (auto simp: pdevs_val_sum)

abbreviation degree_aform::"'a::real_vector aform ⇒ nat"
  where "degree_aform X ≡ degree (snd X)"

lemma degree_cong: "(⋀i. (pdevs_apply x i = 0) = (pdevs_apply y i = 0)) ⟹ degree x = degree y"
  unfolding degree_def
  by auto

lemma Least_True_nat[intro, simp]: "(LEAST i::nat. True) = 0"
  by (metis (lifting) One_nat_def less_one not_less_Least not_less_eq)

lemma sorted_list_of_pdevs_domain_eq:
  "sorted_list_of_set (pdevs_domain X) = filter ((≠) 0 o pdevs_apply X) [0..<degree X]"
  by (auto simp: degree_gt intro!: sorted_distinct_set_unique sorted_filter[of "λx. x", simplified])


subsection ‹Total Deviation›

definition tdev::"'a::ordered_euclidean_space pdevs ⇒ 'a" where
  "tdev x = (∑i<degree x. ¦pdevs_apply x i¦)"

lemma abs_pdevs_val_le_tdev: "e ∈ UNIV → {-1 .. 1} ⟹ ¦pdevs_val e x¦ ≤ tdev x"
  by (force simp: pdevs_val_sum tdev_def abs_scaleR Pi_iff
    intro!: order_trans[OF sum_abs] sum_mono scaleR_left_le_one_le
    intro: abs_leI)


subsection ‹Binary Pointwise Operations›

definition binop_pdevs_raw::"('a::zero ⇒ 'b::zero ⇒ 'c::zero) ⇒
    (nat ⇒ 'a) ⇒ (nat ⇒ 'b) ⇒ nat ⇒ 'c"
  where "binop_pdevs_raw f x y i = (if x i = 0 ∧ y i = 0 then 0 else f (x i) (y i))"

lemma nonzeros_binop_pdevs_subset:
  "{i. binop_pdevs_raw f x y i ≠ 0} ⊆ {i. x i ≠ 0} ∪ {i. y i ≠ 0}"
  by (auto simp: binop_pdevs_raw_def)

lift_definition binop_pdevs::
    "('a ⇒ 'b ⇒ 'c) ⇒ 'a::zero pdevs ⇒ 'b::zero pdevs ⇒ 'c::zero pdevs"
  is binop_pdevs_raw
  using nonzeros_binop_pdevs_subset
  by (rule finite_subset) auto

lemma pdevs_apply_binop_pdevs[simp]: "pdevs_apply (binop_pdevs f x y) i =
  (if pdevs_apply x i = 0 ∧ pdevs_apply y i = 0 then 0 else f (pdevs_apply x i) (pdevs_apply y i))"
  by transfer (auto simp: binop_pdevs_raw_def)


subsection ‹Addition›

definition add_pdevs::"'a::real_vector pdevs ⇒ 'a pdevs ⇒ 'a pdevs"
  where "add_pdevs = binop_pdevs (+)"

lemma pdevs_apply_add_pdevs[simp]:
  "pdevs_apply (add_pdevs X Y) n = pdevs_apply X n + pdevs_apply Y n"
  by (auto simp: add_pdevs_def)

lemma pdevs_val_add_pdevs[simp]:
  fixes x y::"'a::euclidean_space"
  shows "pdevs_val e (add_pdevs X Y) = pdevs_val e X + pdevs_val e Y"
proof -
  let ?sum = "λm X. ∑i < m. e i *⇩_R pdevs_apply X i"
  let ?m = "max (degree X) (degree Y)"
  have "pdevs_val e X + pdevs_val e Y = ?sum (degree X) X + ?sum (degree Y) Y"
    by (simp add: pdevs_val_sum)
  also have "?sum (degree X) X = ?sum ?m X"
    by (rule sum.mono_neutral_cong_left) auto
  also have "?sum (degree Y) Y = ?sum ?m Y"
    by (rule sum.mono_neutral_cong_left) auto
  also have "?sum ?m X + ?sum ?m Y = (∑i < ?m. e i *⇩_R (pdevs_apply X i + pdevs_apply Y i))"
    by (simp add: scaleR_right_distrib sum.distrib)
  also have "… = (∑i. e i *⇩_R (pdevs_apply X i + pdevs_apply Y i))"
    by (rule suminf_finite[symmetric]) auto
  also have "… = pdevs_val e (add_pdevs X Y)"
    by (simp add: pdevs_val_def)
  finally show "pdevs_val e (add_pdevs X Y) = pdevs_val e X + pdevs_val e Y" by simp
qed


subsection ‹Total Deviation›

lemma tdev_eq_zero_iff: fixes X::"real pdevs" shows "tdev X = 0 ⟷ (∀e. pdevs_val e X = 0)"
  by (force simp add: pdevs_val_sum tdev_def sum_nonneg_eq_0_iff
    dest!: spec[where x="λi. if pdevs_apply X i ≥ 0 then 1 else -1"] split: if_split_asm)

lemma tdev_nonneg[intro, simp]: "tdev X ≥ 0"
  by (auto simp: tdev_def)

lemma tdev_nonpos_iff[simp]: "tdev X ≤ 0 ⟷ tdev X = 0"
  by (auto simp: order.antisym)


subsection ‹Unary Operations›

definition unop_pdevs_raw::
    "('a::zero ⇒ 'b::zero) ⇒ (nat ⇒ 'a) ⇒ nat ⇒ 'b"
  where "unop_pdevs_raw f x i = (if x i = 0 then 0 else f (x i))"

lemma nonzeros_unop_pdevs_subset: "{i. unop_pdevs_raw f x i ≠ 0} ⊆ {i. x i ≠ 0}"
  by (auto simp: unop_pdevs_raw_def)

lift_definition unop_pdevs::
    "('a ⇒ 'b) ⇒ 'a::zero pdevs ⇒ 'b::zero pdevs"
  is unop_pdevs_raw
  using nonzeros_unop_pdevs_subset
  by (rule finite_subset) auto

lemma pdevs_apply_unop_pdevs[simp]: "pdevs_apply (unop_pdevs f x) i =
  (if pdevs_apply x i = 0 then 0 else f (pdevs_apply x i))"
  by transfer (auto simp: unop_pdevs_raw_def)

lemma pdevs_domain_unop_linear:
  assumes "linear f"
  shows "pdevs_domain (unop_pdevs f x) ⊆ pdevs_domain x"
proof -
  interpret f: linear f by fact
  show ?thesis
    by (auto simp: f.zero)
qed

lemma
  pdevs_val_unop_linear:
  assumes "linear f"
  shows "pdevs_val e (unop_pdevs f x) = f (pdevs_val e x)"
proof -
  interpret f: linear f by fact
  have *: "⋀i. (if pdevs_apply x i = 0 then 0 else f (pdevs_apply x i)) = f (pdevs_apply x i)"
    by (auto simp: f.zero)
  have "pdevs_val e (unop_pdevs f x) =
      (∑i∈pdevs_domain (unop_pdevs f x). e i *⇩_R f (pdevs_apply x i))"
    by (auto simp add: pdevs_val_pdevs_domain *)
  also have "… = (∑xa∈pdevs_domain x. e xa *⇩_R f (pdevs_apply x xa))"
    by (auto intro!: sum.mono_neutral_cong_left)
  also have "… = f (pdevs_val e x)"
    by (auto simp add: pdevs_val_pdevs_domain f.sum f.scaleR)
  finally show ?thesis .
qed


subsection ‹Pointwise Scaling of Partial Deviations›

definition scaleR_pdevs::"real ⇒ 'a::real_vector pdevs ⇒ 'a pdevs"
  where "scaleR_pdevs r x = unop_pdevs ((*⇩_R) r) x"

lemma pdevs_apply_scaleR_pdevs[simp]:
  "pdevs_apply (scaleR_pdevs x Y) n = x *⇩_R pdevs_apply Y n"
  by (auto simp: scaleR_pdevs_def)

lemma degree_scaleR_pdevs[simp]: "degree (scaleR_pdevs r x) = (if r = 0 then 0 else degree x)"
  unfolding degree_def
  by auto

lemma pdevs_val_scaleR_pdevs[simp]:
  fixes x::real and Y::"'a::real_normed_vector pdevs"
  shows "pdevs_val e (scaleR_pdevs x Y) = x *⇩_R pdevs_val e Y"
  by (auto simp: pdevs_val_sum scaleR_sum_right ac_simps)


subsection ‹Partial Deviations Scale Pointwise›

definition pdevs_scaleR::"real pdevs ⇒ 'a::real_vector ⇒ 'a pdevs"
  where "pdevs_scaleR r x = unop_pdevs (λr. r *⇩_R x) r"

lemma pdevs_apply_pdevs_scaleR[simp]:
  "pdevs_apply (pdevs_scaleR X y) n = pdevs_apply X n *⇩_R y"
  by (auto simp: pdevs_scaleR_def)

lemma degree_pdevs_scaleR[simp]: "degree (pdevs_scaleR r x) = (if x = 0 then 0 else degree r)"
  unfolding degree_def
  by auto

lemma pdevs_val_pdevs_scaleR[simp]:
  fixes X::"real pdevs" and y::"'a::real_normed_vector"
  shows "pdevs_val e (pdevs_scaleR X y) = pdevs_val e X *⇩_R y"
  by (auto simp: pdevs_val_sum scaleR_sum_left)


subsection ‹Pointwise Unary Minus›

definition uminus_pdevs::"'a::real_vector pdevs ⇒ 'a pdevs"
  where "uminus_pdevs = unop_pdevs uminus"

lemma pdevs_apply_uminus_pdevs[simp]: "pdevs_apply (uminus_pdevs x) = - pdevs_apply x"
  by (auto simp: uminus_pdevs_def)

lemma degree_uminus_pdevs[simp]: "degree (uminus_pdevs x) = degree x"
  by (rule degree_cong) simp

lemma pdevs_val_uminus_pdevs[simp]: "pdevs_val e (uminus_pdevs x) = - pdevs_val e x"
  unfolding pdevs_val_sum
  by (auto simp: sum_negf)

definition "uminus_aform X = (- fst X, uminus_pdevs (snd X))"

lemma fst_uminus_aform[simp]: "fst (uminus_aform Y) = - fst Y"
  by (simp add: uminus_aform_def)

lemma aform_val_uminus_aform[simp]: "aform_val e (uminus_aform X) = - aform_val e X"
  by (auto simp: uminus_aform_def aform_val_def)


subsection ‹Constant›

lift_definition zero_pdevs::"'a::zero pdevs" is "λ_. 0" by simp

lemma pdevs_apply_zero_pdevs[simp]: "pdevs_apply zero_pdevs i = 0"
  by transfer simp

lemma pdevs_val_zero_pdevs[simp]: "pdevs_val e zero_pdevs = 0"
  by (auto simp: pdevs_val_def)

definition "num_aform f = (f, zero_pdevs)"


subsection ‹Inner Product›

definition pdevs_inner::"'a::euclidean_space pdevs ⇒ 'a ⇒ real pdevs"
  where "pdevs_inner x b = unop_pdevs (λx. x ∙ b) x"

lemma pdevs_apply_pdevs_inner[simp]: "pdevs_apply (pdevs_inner p a) i = pdevs_apply p i ∙ a"
  by (simp add: pdevs_inner_def)

lemma pdevs_val_pdevs_inner[simp]: "pdevs_val e (pdevs_inner p a) = pdevs_val e p ∙ a"
  by (auto simp add: inner_sum_left pdevs_val_pdevs_domain intro!: sum.mono_neutral_cong_left)

definition inner_aform::"'a::euclidean_space aform ⇒ 'a ⇒ real aform"
  where "inner_aform X b = (fst X ∙ b, pdevs_inner (snd X) b)"



subsection ‹Inner Product Pair›

definition inner2::"'a::euclidean_space ⇒ 'a ⇒ 'a ⇒ real*real"
  where "inner2 x n l = (x ∙ n, x ∙ l)"

definition pdevs_inner2::"'a::euclidean_space pdevs ⇒ 'a ⇒ 'a ⇒ (real*real) pdevs"
  where "pdevs_inner2 X n l = unop_pdevs (λx. inner2 x n l) X"

lemma pdevs_apply_pdevs_inner2[simp]: "pdevs_apply (pdevs_inner2 p a b) i = (pdevs_apply p i ∙ a, pdevs_apply p i ∙ b)"
  by (simp add: pdevs_inner2_def inner2_def zero_prod_def)

definition inner2_aform::"'a::euclidean_space aform ⇒ 'a ⇒ 'a ⇒ (real*real) aform"
  where "inner2_aform X a b = (inner2 (fst X) a b, pdevs_inner2 (snd X) a b)"

lemma linear_inner2[intro, simp]: "linear (λx. inner2 x n i)"
  by unfold_locales (auto simp: inner2_def algebra_simps)

lemma aform_val_inner2_aform[simp]: "aform_val e (inner2_aform Z n i) = inner2 (aform_val e Z) n i"
proof -
  have "aform_val e (inner2_aform Z n i) = inner2 (fst Z) n i + inner2 (pdevs_val e (snd Z)) n i"
    by (auto simp: aform_val_def inner2_aform_def pdevs_inner2_def pdevs_val_unop_linear)
  also have "… = inner2 (aform_val e Z) n i"
    by (simp add: inner2_def algebra_simps aform_val_def)
  finally show ?thesis .
qed


subsection ‹Update›

lemma pdevs_val_upd[simp]:
  "pdevs_val (e(n := e')) X = pdevs_val e X - e n * pdevs_apply X n + e' * pdevs_apply X n"
  unfolding pdevs_val_def
  by (subst suminf_finite[OF finite.insertI[OF finite_degree_nonzero], of n X],
    auto simp: pdevs_val_def sum.insert_remove)+

lemma nonzeros_fun_upd:
  "{i. (f(n := a)) i ≠ 0} ⊆ {i. f i ≠ 0} ∪ {n}"
  by (auto split: if_split_asm)

lift_definition pdev_upd::"'a::real_vector pdevs ⇒ nat ⇒ 'a ⇒ 'a pdevs"
  is "λx n a. x(n:=a)"
  by (rule finite_subset[OF nonzeros_fun_upd]) simp

lemma pdevs_apply_pdev_upd[simp]:
  "pdevs_apply (pdev_upd X n x) = (pdevs_apply X)(n:=x)"
  by transfer simp

lemma pdevs_val_pdev_upd[simp]:
  "pdevs_val e (pdev_upd X n x) = pdevs_val e X + e n *⇩_R x - e n *⇩_R pdevs_apply X n"
  unfolding pdevs_val_def
  by (subst suminf_finite[OF finite.insertI[OF finite_degree_nonzero], of n X],
    auto simp: pdevs_val_def sum.insert_remove)+

lemma degree_pdev_upd:
  assumes "x = 0 ⟷ pdevs_apply X n = 0"
  shows "degree (pdev_upd X n x) = degree X"
  using assms
  by (auto intro!: degree_cong split: if_split_asm)

lemma degree_pdev_upd_le:
  assumes "degree X ≤ n"
  shows "degree (pdev_upd X n x) ≤ Suc n"
  using assms
  by (auto intro!: degree_le)


subsection ‹Inf/Sup›

definition "Inf_aform X = fst X - tdev (snd X)"

definition "Sup_aform X = fst X + tdev (snd X)"

lemma Inf_aform:
  assumes "e ∈ UNIV → {-1 .. 1}"
  shows "Inf_aform X ≤ aform_val e X"
  using order_trans[OF abs_ge_minus_self abs_pdevs_val_le_tdev[OF assms]]
  by (auto simp: Inf_aform_def aform_val_def minus_le_iff)

lemma Sup_aform:
  assumes "e ∈ UNIV → {-1 .. 1}"
  shows "aform_val e X ≤ Sup_aform X"
  using order_trans[OF abs_ge_self abs_pdevs_val_le_tdev[OF assms]]
  by (auto simp: Sup_aform_def aform_val_def)


subsection ‹Minkowski Sum›

definition msum_pdevs_raw::"nat⇒(nat ⇒ 'a::real_vector)⇒(nat ⇒ 'a)⇒(nat⇒'a)" where
  "msum_pdevs_raw n x y i = (if i < n then x i else y (i - n))"

lemma nonzeros_msum_pdevs_raw:
  "{i. msum_pdevs_raw n f g i ≠ 0} = ({0..<n} ∩ {i. f i ≠ 0}) ∪ (+) n ` ({i. g i ≠ 0})"
  by (force simp: msum_pdevs_raw_def not_less split: if_split_asm)

lift_definition msum_pdevs::"nat⇒'a::real_vector pdevs⇒'a pdevs⇒'a pdevs" is msum_pdevs_raw
  unfolding nonzeros_msum_pdevs_raw by simp

lemma pdevs_apply_msum_pdevs: "pdevs_apply (msum_pdevs n f g) i =
  (if i < n then pdevs_apply f i else pdevs_apply g (i - n))"
  by transfer (auto simp: msum_pdevs_raw_def)

lemma degree_least_nonzero:
  assumes "degree f ≠ 0"
  shows "pdevs_apply f (degree f - 1) ≠ 0"
proof
  assume H: "pdevs_apply f (degree f - 1) = 0"
  {
    fix j
    assume "j≥degree f - 1"
    with H have "pdevs_apply f j = 0"
      by (cases "degree f - 1 = j") auto
  }
  from degree_le[rule_format, OF this]
  have "degree f ≤ degree f - 1"
    by blast
  with assms show False by simp
qed

lemma degree_leI:
  assumes "(⋀i. pdevs_apply y i = 0 ⟹ pdevs_apply x i = 0)"
  shows "degree x ≤ degree y"
proof cases
  assume "degree x ≠ 0"
  from degree_least_nonzero[OF this]
  have "pdevs_apply y (degree x - 1) ≠ 0"
    by (auto simp: assms split: if_split_asm)
  from degree_gt[OF this] show ?thesis
    by simp
qed simp

lemma degree_msum_pdevs_ge1:
  shows "degree f ≤ n ⟹ degree f ≤ degree (msum_pdevs n f g)"
  by (rule degree_leI) (auto simp: pdevs_apply_msum_pdevs split: if_split_asm)

lemma degree_msum_pdevs_ge2:
  assumes "degree f ≤ n"
  shows "degree g ≤ degree (msum_pdevs n f g) - n"
proof cases
  assume "degree g ≠ 0"
  hence "pdevs_apply g (degree g - 1) ≠ 0" by (rule degree_least_nonzero)
  hence "pdevs_apply (msum_pdevs n f g) (n + degree g - 1) ≠ 0"
    using assms
    by (auto simp: pdevs_apply_msum_pdevs)
  from degree_gt[OF this]
  show ?thesis
    by simp
qed simp

lemma degree_msum_pdevs_le:
  shows "degree (msum_pdevs n f g) ≤ n + degree g"
  by (auto intro!: degree_le simp: pdevs_apply_msum_pdevs)

lemma
  sum_msum_pdevs_cases:
  assumes "degree f ≤ n"
  assumes [simp]: "⋀i. e i 0 = 0"
  shows
    "(∑i <degree (msum_pdevs n f g).
      e i (if i < n then pdevs_apply f i else pdevs_apply g (i - n))) =
    (∑i <degree f. e i (pdevs_apply f i)) + (∑i <degree g. e (i + n) (pdevs_apply g i))"
  (is "?lhs = ?rhs")
proof -
  have "?lhs = (∑i∈{..<degree (msum_pdevs n f g)} ∩ {i. i < n}. e i (pdevs_apply f i)) +
    (∑i∈{..<degree (msum_pdevs n f g)} ∩ - {i. i < n}. e i (pdevs_apply g (i - n)))"
    (is "_ = ?sum_f + ?sum_g")
     by (simp add: sum.If_cases if_distrib)
  also have "?sum_f = (∑i = 0..<degree f. e i (pdevs_apply f i))"
    using assms degree_msum_pdevs_ge1[of f n g]
    by (intro sum.mono_neutral_cong_right) auto
  also
  have "?sum_g = (∑i∈{0 + n..<degree (msum_pdevs n f g) - n + n}. e i (pdevs_apply g (i - n)))"
    by (rule sum.cong) auto
  also have "… = (∑i = 0..<degree (msum_pdevs n f g) - n. e (i + n) (pdevs_apply g (i + n - n)))"
    by (rule sum.shift_bounds_nat_ivl)
  also have "… = (∑i = 0..<degree g. e (i + n) (pdevs_apply g i))"
    using assms degree_msum_pdevs_ge2[of f n]
    by (intro sum.mono_neutral_cong_right) (auto intro!: sum.mono_neutral_cong_right)
  finally show ?thesis
    by (simp add: atLeast0LessThan)
qed

lemma tdev_msum_pdevs: "degree f ≤ n ⟹ tdev (msum_pdevs n f g) = tdev f + tdev g"
  by (auto simp: tdev_def pdevs_apply_msum_pdevs intro!: sum_msum_pdevs_cases)

lemma pdevs_val_msum_pdevs:
  "degree f ≤ n ⟹ pdevs_val e (msum_pdevs n f g) = pdevs_val e f + pdevs_val (λi. e (i + n)) g"
  by (auto simp: pdevs_val_sum pdevs_apply_msum_pdevs intro!: sum_msum_pdevs_cases)

definition msum_aform::"nat ⇒ 'a::real_vector aform ⇒ 'a aform ⇒ 'a aform"
  where "msum_aform n f g = (fst f + fst g, msum_pdevs n (snd f) (snd g))"

lemma fst_msum_aform[simp]: "fst (msum_aform n f g) = fst f + fst g"
  by (simp add: msum_aform_def)

lemma snd_msum_aform[simp]: "snd (msum_aform n f g) = msum_pdevs n (snd f) (snd g)"
  by (simp add: msum_aform_def)

lemma finite_nonzero_summable: "finite {i. f i ≠ 0} ⟹ summable f"
  by (auto intro!: sums_summable sums_finite)

lemma aform_val_msum_aform:
  assumes "degree_aform f ≤ n"
  shows "aform_val e (msum_aform n f g) = aform_val e f + aform_val (λi. e (i + n)) g"
  using assms
  by (auto simp: pdevs_val_msum_pdevs aform_val_def)

lemma Inf_aform_msum_aform:
  "degree_aform X ≤ n ⟹ Inf_aform (msum_aform n X Y) = Inf_aform X + Inf_aform Y"
  by (simp add: Inf_aform_def tdev_msum_pdevs)

lemma Sup_aform_msum_aform:
  "degree_aform X ≤ n ⟹ Sup_aform (msum_aform n X Y) = Sup_aform X + Sup_aform Y"
  by (simp add: Sup_aform_def tdev_msum_pdevs)

definition "independent_from d Y = msum_aform d (0, zero_pdevs) Y"

definition "independent_aform X Y = independent_from (degree_aform X) Y"

lemma degree_zero_pdevs[simp]: "degree zero_pdevs = 0"
  by (metis degree_least_nonzero pdevs_apply_zero_pdevs)

lemma independent_aform_Joints:
  assumes "x ∈ Affine X"
  assumes "y ∈ Affine Y"
  shows "[x, y] ∈ Joints [X, independent_aform X Y]"
  using assms
  unfolding Affine_def valuate_def Joints_def
  apply safe
  subgoal premises prems for e ea
    using prems
    by (intro image_eqI[where x="λi. if i < degree_aform X then e i else ea (i - degree_aform X)"])
      (auto simp: aform_val_def pdevs_val_msum_pdevs Pi_iff
      independent_aform_def independent_from_def intro!: pdevs_val_degree_cong)
  done

lemma msum_aform_Joints:
  assumes "d ≥ degree_aform X"
  assumes "⋀X. X ∈ set XS ⟹ d ≥ degree_aform X"
  assumes "(x#xs) ∈ Joints (X#XS)"
  assumes "y ∈ Affine Y"
  shows "((x + y)#x#xs) ∈ Joints (msum_aform d X Y#X#XS)"
  using assms
  unfolding Joints_def valuate_def Affine_def
proof (safe, goal_cases)
  case (1 e ea a b zs)
  then show ?case
    by (intro image_eqI[where x = "λi. if i < d then e i else ea (i - d)"])
      (force simp: aform_val_def pdevs_val_msum_pdevs intro!: intro!: pdevs_val_degree_cong)+
qed

lemma Joints_msum_aform:
  assumes "d ≥ degree_aform X"
  assumes "⋀Y. Y ∈ set YS ⟹ d ≥ degree_aform Y"
  shows "Joints (msum_aform d X Y#YS) = {((x + y)#ys) |x y ys. y ∈ Affine Y ∧ x#ys ∈ Joints (X#YS)}"
  unfolding Affine_def valuate_def Joints_def
proof (safe, goal_cases)
  case (1 x e)
  thus ?case
    using assms
    by (intro exI[where x = "aform_val e X"] exI[where x = "aform_val ((λi. e (i + d))) Y"])
      (auto simp add: aform_val_def pdevs_val_msum_pdevs)
next
  case (2 x xa y ys e ea)
  thus ?case using assms
    by (intro image_eqI[where x="λi. if i < d then ea i else e (i - d)"])
       (force simp: aform_val_def pdevs_val_msum_pdevs Pi_iff intro!: pdevs_val_degree_cong)+
qed

lemma Joints_singleton_image: "Joints [x] = (λx. [x]) ` Affine x"
  by (auto simp: Joints_def Affine_def valuate_def)

lemma Collect_extract_image: "{g (f x y) |x y. P x y} = g ` {f x y |x y. P x y}"
  by auto

lemma inj_Cons: "inj (λx. x#xs)"
  by (auto intro!: injI)

lemma Joints_Nil[simp]: "Joints [] = {[]}"
  by (force simp: Joints_def valuate_def)

lemma msum_pdevs_zero_ident[simp]: "msum_pdevs 0 zero_pdevs x = x"
  by transfer (auto simp: msum_pdevs_raw_def)

lemma msum_aform_zero_ident[simp]: "msum_aform 0 (0, zero_pdevs) x = x"
  by (simp add: msum_aform_def)

lemma mem_Joints_singleton: "(x ∈ Joints [X]) = (∃y. x = [y] ∧ y ∈ Affine X)"
  by (auto simp: Affine_def valuate_def Joints_def)

lemma singleton_mem_Joints[simp]: "[x] ∈ Joints [X] ⟷ x ∈ Affine X"
  by (auto simp: mem_Joints_singleton)

lemma msum_aform_Joints_without_first:
  assumes "d ≥ degree_aform X"
  assumes "⋀X. X ∈ set XS ⟹ d ≥ degree_aform X"
  assumes "(x#xs) ∈ Joints (X#XS)"
  assumes "y ∈ Affine Y"
  assumes "z = x + y"
  shows "z#xs ∈ Joints (msum_aform d X Y#XS)"
  unfolding ‹z = x + y›
  using msum_aform_Joints[OF assms(1-4)]
  by (force simp: Joints_def valuate_def)

lemma Affine_msum_aform:
  assumes "d ≥ degree_aform X"
  shows "Affine (msum_aform d X Y) = {x + y |x y. x ∈ Affine X ∧ y ∈ Affine Y}"
  using Joints_msum_aform[OF assms, of Nil Y, simplified, unfolded mem_Joints_singleton]
  by (auto simp add: Joints_singleton_image Collect_extract_image[where g="λx. [x]"]
    inj_image_eq_iff[OF inj_Cons] )

lemma Affine_zero_pdevs[simp]: "Affine (0, zero_pdevs) = {0}"
  by (force simp: Affine_def valuate_def aform_val_def)

lemma Affine_independent_aform:
  "Affine (independent_aform X Y) = Affine Y"
  by (auto simp: independent_aform_def independent_from_def Affine_msum_aform)

lemma
  abs_diff_eq1:
  fixes l u::"'a::ordered_euclidean_space"
  shows "l ≤ u ⟹ ¦u - l¦ = u - l"
  by (metis abs_of_nonneg diff_add_cancel le_add_same_cancel2)

lemma compact_sum:
  fixes f :: "'a ⇒ 'b::topological_space ⇒ 'c::real_normed_vector"
  assumes "finite I"
  assumes "⋀i. i ∈ I ⟹ compact (S i)"
  assumes "⋀i. i ∈ I ⟹ continuous_on (S i) (f i)"
  assumes "I ⊆ J"
  shows "compact {∑i∈I. f i (x i) | x. x ∈ Pi J S}"
  using assms
proof (induct I)
  case empty
  thus ?case
  proof (cases "∃x. x ∈ Pi J S")
    case False
    hence *: "{∑i∈{}. f i (x i) |x. x ∈ Pi J S} = {}"
      by (auto simp: Pi_iff)
    show ?thesis unfolding * by simp
  qed auto
next
  case (insert a I)
  hence "{∑i∈insert a I. f i (xa i) |xa. xa ∈ Pi J S}
    = {x + y |x y. x ∈ f a ` S a ∧ y ∈ {∑i∈I. f i (x i) |x. x ∈ Pi J S}}"
  proof safe
    fix s x
    assume "s ∈ S a" "x ∈ Pi J S"
    thus "∃xa. f a s + (∑i∈I. f i (x i)) = (∑i∈insert a I. f i (xa i)) ∧ xa ∈ Pi J S"
      using insert
      by (auto intro!: exI[where x="x(a:=s)"] sum.cong)
  qed force
  also have "compact …"
    using insert
    by (intro compact_sums) (auto intro!: compact_continuous_image)
  finally show ?case .
qed

lemma compact_Affine:
  fixes X::"'a::ordered_euclidean_space aform"
  shows "compact (Affine X)"
proof -
  have "Affine X = {x + y|x y. x ∈ {fst X} ∧
      y ∈ {(∑i ∈ {0..<degree_aform X}. e i *⇩_R pdevs_apply (snd X) i) | e. e ∈ UNIV → {-1 .. 1}}}"
    by (auto simp: Affine_def valuate_def aform_val_def pdevs_val_sum atLeast0LessThan)
  also have "compact …"
    by (rule compact_sums) (auto intro!: compact_sum continuous_intros)
  finally show ?thesis .
qed

lemma Joints2_JointsI:
  "(xs, x) ∈ Joints2 XS X ⟹ x#xs ∈ Joints (X#XS)"
  by (auto simp: Joints_def Joints2_def valuate_def)


subsection ‹Splitting›

definition "split_aform X i =
  (let xi = pdevs_apply (snd X) i /⇩_R 2
  in ((fst X - xi, pdev_upd (snd X) i xi), (fst X + xi, pdev_upd (snd X) i xi)))"

lemma split_aformE:
  assumes "e ∈ UNIV → {-1 .. 1}"
  assumes "x = aform_val e X"
  obtains err where "x = aform_val (e(i:=err)) (fst (split_aform X i))" "err ∈ {-1 .. 1}"
    | err where "x = aform_val (e(i:=err)) (snd (split_aform X i))" "err ∈ {-1 .. 1}"
proof (atomize_elim)
  let ?thesis = "(∃err. x = aform_val (e(i := err)) (fst (split_aform X i)) ∧ err ∈ {- 1..1}) ∨
    (∃err. x = aform_val (e(i := err)) (snd (split_aform X i)) ∧ err ∈ {- 1..1})"
  {
    assume "pdevs_apply (snd X) i = 0"
    hence "X = fst (split_aform X i)"
      by (auto simp: split_aform_def intro!: prod_eqI pdevs_eqI)
    with assms have ?thesis by (auto intro!: exI[where x="e i"])
  } moreover {
    assume "pdevs_apply (snd X) i ≠ 0"
    hence [simp]: "degree_aform X > i"
      by (rule degree_gt)
    note assms(2)
    also
    have "aform_val e X = fst X + (∑i<degree_aform X. e i *⇩_R pdevs_apply (snd X) i)"
      by (simp add: aform_val_def pdevs_val_sum)
    also
    have rewr: "{..<degree_aform X} = {0..<degree_aform X} - {i} ∪ {i}"
      by auto
    have "(∑i<degree_aform X. e i *⇩_R pdevs_apply (snd X) i) =
        (∑i ∈ {0..<degree_aform X} - {i}. e i *⇩_R pdevs_apply (snd X) i) +
        e i *⇩_R pdevs_apply (snd X) i"
      by (subst rewr, subst sum.union_disjoint) auto
    finally have "x = fst X + …" .
    hence "x = aform_val (e(i:=2 * e i - 1)) (snd (split_aform X i))"
        "x = aform_val (e(i:=2 * e i + 1)) (fst (split_aform X i))"
      by (auto simp: aform_val_def split_aform_def Let_def pdevs_val_sum atLeast0LessThan
        Diff_eq degree_pdev_upd if_distrib sum.If_cases field_simps
        scaleR_left_distrib[symmetric])
    moreover
    have "2 * e i - 1 ∈ {-1 .. 1} ∨ 2 * e i + 1 ∈ {-1 .. 1}"
      using assms by (auto simp: not_le Pi_iff dest!: spec[where x=i])
    ultimately have ?thesis by blast
  } ultimately show ?thesis by blast
qed

lemma pdevs_val_add: "pdevs_val (λi. e i + f i) xs = pdevs_val e xs + pdevs_val f xs"
  by (auto simp: pdevs_val_pdevs_domain algebra_simps sum.distrib)

lemma pdevs_val_minus: "pdevs_val (λi. e i - f i) xs = pdevs_val e xs - pdevs_val f xs"
  by (auto simp: pdevs_val_pdevs_domain algebra_simps sum_subtractf)

lemma pdevs_val_cmul: "pdevs_val (λi. u * e i) xs = u *⇩_R pdevs_val e xs"
  by (auto simp: pdevs_val_pdevs_domain scaleR_sum_right)

lemma atLeastAtMost_absI: "- a ≤ a ⟹ ¦x::real¦ ≤ ¦a¦ ⟹ x ∈ atLeastAtMost (- a) a"
  by auto

lemma divide_atLeastAtMost_1_absI: "¦x::real¦ ≤ ¦a¦ ⟹ x/a ∈ {-1 .. 1}"
  by (intro atLeastAtMost_absI) (auto simp: divide_le_eq_1)

lemma convex_scaleR_aux: "u + v = 1 ⟹ u *⇩_R x + v *⇩_R x = (x::'a::real_vector)"
  by (metis scaleR_add_left scaleR_one)

lemma convex_mult_aux: "u + v = 1 ⟹ u * x + v * x = (x::real)"
  using convex_scaleR_aux[of u v x] by simp

lemma convex_Affine: "convex (Affine X)"
proof (rule convexI)
  fix x y::'a and u v::real
  assume "x ∈ Affine X" "y ∈ Affine X" and convex: "0 ≤ u" "0 ≤ v" "u + v = 1"
  then obtain e f where x: "x = aform_val e X" "e ∈ UNIV → {-1 .. 1}"
    and y: "y = aform_val f X" "f ∈ UNIV → {-1 .. 1}"
    by (auto simp: Affine_def valuate_def)
  let ?conv = "λi. u * e i + v * f i"
  {
    fix i
    have "¦?conv i¦ ≤ u * ¦e i¦ + v * ¦f i¦"
      using convex by (intro order_trans[OF abs_triangle_ineq]) (simp add: abs_mult)
    also have "… ≤ 1"
      using convex x y
      by (intro convex_bound_le) (auto simp: Pi_iff abs_real_def)
    finally have "?conv i ≤ 1" "-1 ≤ ?conv i"
      by (auto simp: abs_real_def split: if_split_asm)
  }
  thus "u *⇩_R x + v *⇩_R y ∈ Affine X"
    using convex x y
    by (auto simp: Affine_def valuate_def aform_val_def pdevs_val_add pdevs_val_cmul algebra_simps
      convex_scaleR_aux intro!: image_eqI[where x="?conv"])
qed

lemma segment_in_aform_val:
  assumes "e ∈ UNIV → {-1 .. 1}"
  assumes "f ∈ UNIV → {-1 .. 1}"
  shows "closed_segment (aform_val e X) (aform_val f X) ⊆ Affine X"
proof -
  have "aform_val e X ∈ Affine X" "aform_val f X ∈ Affine X"
    using assms by (auto simp: Affine_def valuate_def)
  with convex_Affine[of X, simplified convex_contains_segment]
  show ?thesis
    by simp
qed


subsection ‹From List of Generators›

lift_definition pdevs_of_list::"'a::zero list ⇒ 'a pdevs"
  is "λxs i. if i < length xs then xs ! i else 0"
  by auto

lemma pdevs_apply_pdevs_of_list:
  "pdevs_apply (pdevs_of_list xs) i = (if i < length xs then xs ! i else 0)"
  by transfer simp

lemma pdevs_apply_pdevs_of_list_Nil[simp]:
  "pdevs_apply (pdevs_of_list []) i = 0"
  by transfer auto

lemma pdevs_apply_pdevs_of_list_Cons:
  "pdevs_apply (pdevs_of_list (x # xs)) i =
    (if i = 0 then x else pdevs_apply (pdevs_of_list xs) (i - 1))"
  by transfer auto

lemma pdevs_domain_pdevs_of_list_Cons[simp]: "pdevs_domain (pdevs_of_list (x # xs)) =
  (if x = 0 then {} else {0}) ∪ (+) 1 ` pdevs_domain (pdevs_of_list xs)"
  by (force simp: pdevs_apply_pdevs_of_list_Cons split: if_split_asm)

lemma pdevs_val_pdevs_of_list_eq[simp]:
  "pdevs_val e (pdevs_of_list (x # xs)) = e 0 *⇩_R x + pdevs_val (e o (+) 1) (pdevs_of_list xs)"
proof -
  have "pdevs_val e (pdevs_of_list (x # xs)) =
    (∑i∈pdevs_domain (pdevs_of_list (x # xs)) ∩ {0}. e i *⇩_R x) +
    (∑i∈pdevs_domain (pdevs_of_list (x # xs)) ∩ - {0}.
      e i *⇩_R pdevs_apply (pdevs_of_list xs) (i - Suc 0))"
    (is "_ = ?l + ?r")
    by (simp add: pdevs_val_pdevs_domain if_distrib sum.If_cases pdevs_apply_pdevs_of_list_Cons)
  also
  have "?r = (∑i∈pdevs_domain (pdevs_of_list xs). e (Suc i) *⇩_R pdevs_apply (pdevs_of_list xs) i)"
    by (rule sum.reindex_cong[of "λi. i + 1"]) auto
  also have "… = pdevs_val (e o (+) 1) (pdevs_of_list xs)"
    by (simp add: pdevs_val_pdevs_domain  )
  also have "?l = (∑i∈{0}. e i *⇩_R x)"
    by (rule sum.mono_neutral_cong_left) auto
  also have "… = e 0 *⇩_R x" by simp
  finally show ?thesis .
qed

lemma
  less_degree_pdevs_of_list_imp_less_length:
  assumes "i < degree (pdevs_of_list xs)"
  shows "i < length xs"
proof -
  from assms have "pdevs_apply (pdevs_of_list xs) (degree (pdevs_of_list xs) - 1) ≠ 0"
    by (metis degree_least_nonzero less_nat_zero_code)
  hence "degree (pdevs_of_list xs) - 1 < length xs"
    by (simp add: pdevs_apply_pdevs_of_list split: if_split_asm)
  with assms show ?thesis
    by simp
qed

lemma tdev_pdevs_of_list[simp]: "tdev (pdevs_of_list xs) = sum_list (map abs xs)"
  by (auto simp: tdev_def pdevs_apply_pdevs_of_list sum_list_sum_nth
    less_degree_pdevs_of_list_imp_less_length
    intro!: sum.mono_neutral_cong_left degree_gt)

lemma pdevs_of_list_Nil[simp]: "pdevs_of_list [] = zero_pdevs"
  by (auto intro!: pdevs_eqI)

lemma pdevs_val_inj_sumI:
  fixes K::"'a set" and g::"'a ⇒ nat"
  assumes "finite K"
  assumes "inj_on g K"
  assumes "pdevs_domain x ⊆ g ` K"
  assumes "⋀i. i ∈ K ⟹ g i ∉ pdevs_domain x ⟹ f i = 0"
  assumes "⋀i. i ∈ K ⟹ g i ∈ pdevs_domain x ⟹ f i = e (g i) *⇩_R pdevs_apply x (g i)"
  shows "pdevs_val e x = (∑i∈K. f i)"
proof -
  have [simp]: "inj_on (the_inv_into K g) (pdevs_domain x)"
    using assms
    by (auto simp: intro!: subset_inj_on[OF inj_on_the_inv_into])
  {
    fix y assume y: "y ∈ pdevs_domain x"
    have g_inv: "g (the_inv_into K g y) = y"
      by (meson assms(2) assms(3) y f_the_inv_into_f subset_eq)
    have inv_in: "the_inv_into K g y ∈ K"
      by (meson assms(2) assms(3) y subset_iff in_pdevs_domain the_inv_into_into)
    have inv3: "the_inv_into (pdevs_domain x) (the_inv_into K g) (the_inv_into K g y) =
        g (the_inv_into K g y)"
      using assms y
      by (subst the_inv_into_f_f) (auto simp: f_the_inv_into_f[OF assms(2)])
    note g_inv inv_in inv3
  } note this[simp]
  have "pdevs_val e x = (∑i∈pdevs_domain x. e i *⇩_R pdevs_apply x i)"
    by (simp add: pdevs_val_pdevs_domain)
  also have "… = (∑i ∈ the_inv_into K g ` pdevs_domain x. e (g i) *⇩_R pdevs_apply x (g i))"
    by (rule sum.reindex_cong[OF inj_on_the_inv_into]) auto
  also have "… = (∑i∈K. f i)"
    using assms
    by (intro sum.mono_neutral_cong_left) (auto simp: the_inv_into_image_eq)
  finally show ?thesis .
qed

lemma pdevs_domain_pdevs_of_list_le: "pdevs_domain (pdevs_of_list xs) ⊆ {0..<length xs}"
  by (auto simp: pdevs_apply_pdevs_of_list split: if_split_asm)

lemma pdevs_val_zip: "pdevs_val e (pdevs_of_list xs) = (∑(i,x)←zip [0..<length xs] xs. e i *⇩_R x)"
  by (auto simp: sum_list_distinct_conv_sum_set
    in_set_zip image_fst_zip pdevs_apply_pdevs_of_list distinct_zipI1
    intro!: pdevs_val_inj_sumI[of _ fst]
    split: if_split_asm)

lemma scaleR_sum_list:
  fixes xs::"'a::real_vector list"
  shows "a *⇩_R sum_list xs = sum_list (map (scaleR a) xs)"
  by (induct xs) (auto simp: algebra_simps)

lemma pdevs_val_const_pdevs_of_list: "pdevs_val (λ_. c) (pdevs_of_list xs) = c *⇩_R sum_list xs"
  unfolding pdevs_val_zip split_beta' scaleR_sum_list
  by (rule arg_cong) (auto intro!: nth_equalityI)

lemma pdevs_val_partition:
  assumes "e ∈ UNIV → I"
  obtains f g where "pdevs_val e (pdevs_of_list xs) =
    pdevs_val f (pdevs_of_list (filter p xs)) +
    pdevs_val g (pdevs_of_list (filter (Not o p) xs))"
    "f ∈ UNIV → I"
    "g ∈ UNIV → I"
proof -
  obtain i where i: "i ∈ I"
    by (metis assms funcset_mem iso_tuple_UNIV_I)
  let ?zip = "zip [0..<length xs] xs"
  define part where "part = partition (p ∘ snd) ?zip"
  let ?f =
    "(λn. if n < degree (pdevs_of_list (filter p xs)) then e (map fst (fst part) ! n) else i)"
  let ?g =
    "(λn. if n < degree (pdevs_of_list (filter (Not ∘ p) xs))
      then e (map fst (snd part) ! n)
      else i)"
  show ?thesis
  proof
    have "pdevs_val e (pdevs_of_list xs) = (∑(i,x)←?zip. e i *⇩_R x)"
      by (rule pdevs_val_zip)
    also have "… = (∑(i, x)∈set ?zip. e i *⇩_R x)"
      by (simp add: sum_list_distinct_conv_sum_set distinct_zipI1)
    also
    have [simp]: "set (fst part) ∩ set (snd part) = {}"
      by (auto simp: part_def)
    from partition_set[of "p o snd" ?zip "fst part" "snd part"]
    have "set ?zip = set (fst part) ∪ set (snd part)"
      by (auto simp: part_def)
    also have "(∑a∈set (fst part) ∪ set (snd part). case a of (i, x) ⇒ e i *⇩_R x) =
        (∑(i, x)∈set (fst part). e i *⇩_R x) + (∑(i, x)∈set (snd part). e i *⇩_R x)"
      by (auto simp: split_beta sum_Un)
    also
    have "(∑(i, x)∈set (fst part). e i *⇩_R x) = (∑(i, x)←(fst part). e i *⇩_R x)"
      by (simp add: sum_list_distinct_conv_sum_set distinct_zipI1 part_def)
    also have "… = (∑i<length (fst part). case (fst part ! i) of (i, x) ⇒ e i *⇩_R x)"
      by (subst sum_list_sum_nth) (simp add: split_beta' atLeast0LessThan)
    also have "… =
      pdevs_val (λn. e (map fst (fst part) ! n)) (pdevs_of_list (map snd (fst part)))"
      by (force
        simp: pdevs_val_zip sum_list_distinct_conv_sum_set distinct_zipI1 split_beta' in_set_zip
        intro!:
          sum.reindex_cong[where l=fst] image_eqI[where x = "(x, map snd (fst part) ! x)" for x])
    also
    have "(∑(i, x)∈set (snd part). e i *⇩_R x) = (∑(i, x)←(snd part). e i *⇩_R x)"
      by (simp add: sum_list_distinct_conv_sum_set distinct_zipI1 part_def)
    also have "… = (∑i<length (snd part). case (snd part ! i) of (i, x) ⇒ e i *⇩_R x)"
      by (subst sum_list_sum_nth) (simp add: split_beta' atLeast0LessThan)
    also have "… =
      pdevs_val (λn. e (map fst (snd part) ! n)) (pdevs_of_list (map snd (snd part)))"
      by (force simp: pdevs_val_zip sum_list_distinct_conv_sum_set distinct_zipI1 split_beta'
        in_set_zip
        intro!: sum.reindex_cong[where l=fst]
          image_eqI[where x = "(x, map snd (snd part) ! x)" for x])
    also
    have "pdevs_val (λn. e (map fst (fst part) ! n)) (pdevs_of_list (map snd (fst part))) =
      pdevs_val (λn.
          if n < degree (pdevs_of_list (map snd (fst part))) then e (map fst (fst part) ! n) else i)
        (pdevs_of_list (map snd (fst part)))"
      by (rule pdevs_val_degree_cong) simp_all
    also
    have "pdevs_val (λn. e (map fst (snd part) ! n)) (pdevs_of_list (map snd (snd part))) =
      pdevs_val (λn.
          if n < degree (pdevs_of_list (map snd (snd part))) then e (map fst (snd part) ! n) else i)
        (pdevs_of_list (map snd (snd part)))"
      by (rule pdevs_val_degree_cong) simp_all
    also have "map snd (snd part) = filter (Not o p) xs"
      by (simp add: part_def filter_map[symmetric] o_assoc)
    also have "map snd (fst part) = filter p xs"
      by (simp add: part_def filter_map[symmetric])
    finally
    show
      "pdevs_val e (pdevs_of_list xs) =
        pdevs_val ?f (pdevs_of_list (filter p xs)) +
        pdevs_val ?g (pdevs_of_list (filter (Not ∘ p) xs))" .
    show "?f ∈ UNIV → I" "?g ∈ UNIV → I"
      using assms ‹i∈I›
      by (auto simp: Pi_iff)
  qed
qed

lemma pdevs_apply_pdevs_of_list_append:
  "pdevs_apply (pdevs_of_list (xs @ zs)) i =
    (if i < length xs
    then pdevs_apply (pdevs_of_list xs) i else pdevs_apply (pdevs_of_list zs) (i - length xs))"
  by (auto simp: pdevs_apply_pdevs_of_list nth_append)

lemma degree_pdevs_of_list_le_length[intro, simp]: "degree (pdevs_of_list xs) ≤ length xs"
  by (metis less_irrefl_nat le_less_linear less_degree_pdevs_of_list_imp_less_length)

lemma degree_pdevs_of_list_append:
  "degree (pdevs_of_list (xs @ ys)) ≤ length xs + degree (pdevs_of_list ys)"
  by (rule degree_le) (auto simp: pdevs_apply_pdevs_of_list_append)

lemma pdevs_val_pdevs_of_list_append:
  assumes "f ∈ UNIV → I"
  assumes "g ∈ UNIV → I"
  obtains e where
    "pdevs_val f (pdevs_of_list xs) + pdevs_val g (pdevs_of_list ys) =
      pdevs_val e (pdevs_of_list (xs @ ys))"
    "e ∈ UNIV → I"
proof
  let ?e = "(λi. if i < length xs then f i else g (i - length xs))"
  have f: "pdevs_val f (pdevs_of_list xs) =
      (∑i∈{..<length xs}. ?e i *⇩_R pdevs_apply (pdevs_of_list (xs @ ys)) i)"
    by (auto simp: pdevs_val_sum degree_gt pdevs_apply_pdevs_of_list_append
      intro: sum.mono_neutral_cong_left)
  have g: "pdevs_val g (pdevs_of_list ys) =
      (∑i=length xs ..<length xs + degree (pdevs_of_list ys).
        ?e i *⇩_R pdevs_apply (pdevs_of_list (xs @ ys)) i)"
    (is "_ = ?sg")
    by (auto simp: pdevs_val_sum pdevs_apply_pdevs_of_list_append
      intro!: inj_onI image_eqI[where x="length xs + x" for x]
        sum.reindex_cong[where l="λi. i - length xs"])
  show "pdevs_val f (pdevs_of_list xs) + pdevs_val g (pdevs_of_list ys) =
      pdevs_val ?e (pdevs_of_list (xs @ ys))"
    unfolding f g
    by (subst sum.union_disjoint[symmetric])
      (force simp: pdevs_val_sum ivl_disj_un degree_pdevs_of_list_append
        intro!: sum.mono_neutral_cong_right
        split: if_split_asm)+
  show "?e ∈ UNIV → I"
    using assms by (auto simp: Pi_iff)
qed

lemma
  sum_general_mono:
  fixes f::"'a⇒('b::ordered_ab_group_add)"
  assumes [simp,intro]: "finite s" "finite t"
  assumes f: "⋀x. x ∈ s - t ⟹ f x ≤ 0"
  assumes g: "⋀x. x ∈ t - s ⟹ g x ≥ 0"
  assumes fg: "⋀x. x ∈ s ∩ t ⟹ f x ≤ g x"
  shows "(∑x ∈ s. f x) ≤ (∑x ∈ t. g x)"
proof -
  have "s = (s - t) ∪ (s ∩ t)" and [intro, simp]: "(s - t) ∩ (s ∩ t) = {}" by auto
  hence "(∑x ∈ s. f x) = (∑x ∈ s - t ∪ s ∩ t. f x)"
    using assms by simp
  also have "… = (∑x ∈ s - t. f x) + (∑x ∈ s ∩ t. f x)"
    by (simp add: sum_Un)
  also have "(∑x ∈ s - t. f x) ≤ 0"
    by (auto intro!: sum_nonpos f)
  also have "0 ≤ (∑x ∈ t - s. g x)"
    by (auto intro!: sum_nonneg g)
  also have "(∑x ∈ s ∩ t. f x) ≤ (∑x ∈ s ∩ t. g x)"
    by (auto intro!: sum_mono fg)
  also
  have [intro, simp]: "(t - s) ∩ (s ∩ t) = {}" by auto
  hence "sum g (t - s) + sum g (s ∩ t) = sum g ((t - s) ∪ (s ∩ t))"
    by (simp add: sum_Un)
  also have "… = sum g t"
    by (auto intro!: sum.cong)
  finally show ?thesis by simp
qed

lemma pdevs_val_perm_ex:
  assumes "xs <~~> ys"
  assumes mem: "e ∈ UNIV → I"
  shows "∃e'. e' ∈ UNIV → I ∧ pdevs_val e (pdevs_of_list xs) = pdevs_val e' (pdevs_of_list ys)"
  using assms
proof (induct arbitrary: e)
  case Nil
  thus ?case
    by auto
next
  case (Cons xs ys z)
  hence "(e ∘ (+) (Suc 0)) ∈ UNIV → I" by auto
  from Cons(2)[OF this] obtain e' where "e' ∈ UNIV → I"
      "pdevs_val (e ∘ (+) (Suc 0)) (pdevs_of_list xs) = pdevs_val e' (pdevs_of_list ys)"
    by metis
  thus ?case using Cons
    by (auto intro!: exI[where x="λx. if x = 0 then e 0 else e' (x - 1)"] simp: o_def Pi_iff)
next
  case (trans xs ys zs)
  thus ?case by metis
next
  case (swap y x l)
  thus ?case
    by (auto intro!: exI[where x="λi. if i = 0 then e 1 else if i = 1 then e 0 else e i"]
      simp: o_def Pi_iff)
qed

lemma pdevs_val_perm:
  assumes "xs <~~> ys"
  assumes mem: "e ∈ UNIV → I"
  obtains e' where "e' ∈ UNIV → I"
    "pdevs_val e (pdevs_of_list xs) = pdevs_val e' (pdevs_of_list ys)"
  using assms
  by (metis pdevs_val_perm_ex)

lemma set_distinct_permI: "set xs = set ys ⟹ distinct xs ⟹ distinct ys ⟹ xs <~~> ys"
  by (metis eq_set_perm_remdups remdups_id_iff_distinct)

lemmas pdevs_val_permute = pdevs_val_perm[OF set_distinct_permI]

lemma partition_permI:
  "filter p xs @ filter (Not o p) xs <~~> xs"
proof (induct xs)
  case (Cons x xs)
  have swap_app_Cons: "filter p xs @ x # [a←xs . ¬ p a] <~~> x # filter p xs @ [a←xs . ¬ p a]"
    by (metis perm_sym perm_append_Cons)
  also have "… <~~> x#xs"
    using Cons by auto
  finally (trans)
  show ?case using Cons
    by simp
qed simp

lemma pdevs_val_eqI:
  assumes "⋀i. i ∈ pdevs_domain y ⟹ i ∈ pdevs_domain x ⟹
      e i *⇩_R pdevs_apply x i = f i *⇩_R pdevs_apply y i"
  assumes "⋀i. i ∈ pdevs_domain y ⟹ i ∉ pdevs_domain x ⟹ f i *⇩_R pdevs_apply y i = 0"
  assumes "⋀i. i ∈ pdevs_domain x ⟹ i ∉ pdevs_domain y ⟹ e i *⇩_R pdevs_apply x i = 0"
  shows "pdevs_val e x = pdevs_val f y"
  using assms
  by (force simp: pdevs_val_pdevs_domain
    intro!:
      sum.reindex_bij_witness_not_neutral[where
        i=id and j = id and
        S'="pdevs_domain x - pdevs_domain y" and
        T'="pdevs_domain y - pdevs_domain x"])

definition
  filter_pdevs_raw::"(nat ⇒ 'a ⇒ bool) ⇒ (nat ⇒ 'a::real_vector) ⇒ (nat ⇒ 'a)"
  where "filter_pdevs_raw I X = (λi. if I i (X i) then X i else 0)"

lemma filter_pdevs_raw_nonzeros: "{i. filter_pdevs_raw s f i ≠ 0} = {i. f i ≠ 0} ∩ {x. s x (f x)}"
  by (auto simp: filter_pdevs_raw_def)

lift_definition filter_pdevs::"(nat ⇒ 'a ⇒ bool) ⇒ 'a::real_vector pdevs ⇒ 'a pdevs"
  is filter_pdevs_raw
  by (simp add: filter_pdevs_raw_nonzeros)

lemma pdevs_apply_filter_pdevs[simp]:
  "pdevs_apply (filter_pdevs I x) i = (if I i (pdevs_apply x i) then pdevs_apply x i else 0)"
  by transfer (auto simp: filter_pdevs_raw_def)

lemma degree_filter_pdevs_le: "degree (filter_pdevs I x) ≤ degree x"
  by (rule degree_leI) (simp split: if_split_asm)

lemma pdevs_val_filter_pdevs:
  "pdevs_val e (filter_pdevs I x) =
    (∑i ∈ {..<degree x} ∩ {i. I i (pdevs_apply x i)}. e i *⇩_R pdevs_apply x i)"
  by (auto simp: pdevs_val_sum if_distrib sum.inter_restrict degree_filter_pdevs_le degree_gt
    intro!: sum.mono_neutral_cong_left split: if_split_asm)

lemma pdevs_val_filter_pdevs_dom:
  "pdevs_val e (filter_pdevs I x) =
    (∑i ∈ pdevs_domain x ∩ {i. I i (pdevs_apply x i)}. e i *⇩_R pdevs_apply x i)"
  by (auto
    simp: pdevs_val_pdevs_domain if_distrib sum.inter_restrict degree_filter_pdevs_le degree_gt
    intro!: sum.mono_neutral_cong_left split: if_split_asm)

lemma pdevs_val_filter_pdevs_eval:
  "pdevs_val e (filter_pdevs p x) = pdevs_val (λi. if p i (pdevs_apply x i) then e i else 0) x"
  by (auto split: if_split_asm intro!: pdevs_val_eqI)

definition "pdevs_applys X i = map (λx. pdevs_apply x i) X"
definition "pdevs_vals e X = map (pdevs_val e) X"
definition "aform_vals e X = map (aform_val e) X"
definition "filter_pdevs_list I X = map (filter_pdevs (λi _. I i (pdevs_applys X i))) X"

lemma pdevs_applys_filter_pdevs_list[simp]:
  "pdevs_applys (filter_pdevs_list I X) i = (if I i (pdevs_applys X i) then pdevs_applys X i else
    map (λ_. 0) X)"
  by (auto simp: filter_pdevs_list_def o_def pdevs_applys_def)

definition "degrees X = Max (insert 0 (degree ` set X))"

abbreviation "degree_aforms X ≡ degrees (map snd X)"

lemma degrees_leI:
  assumes "⋀x. x ∈ set X ⟹ degree x ≤ K"
  shows "degrees X ≤ K"
  using assms
  by (auto simp: degrees_def intro!: Max.boundedI)

lemma degrees_leD:
  assumes "degrees X ≤ K"
  shows "⋀x. x ∈ set X ⟹ degree x ≤ K"
  using assms
  by (auto simp: degrees_def intro!: Max.boundedI)

lemma degree_filter_pdevs_list_le: "degrees (filter_pdevs_list I x) ≤ degrees x"
  by (rule degrees_leI) (auto simp: filter_pdevs_list_def intro!: degree_le dest!: degrees_leD)


definition "dense_list_of_pdevs x = map (λi. pdevs_apply x i) [0..<degree x]"

subsubsection ‹(reverse) ordered coefficients as list›

definition "list_of_pdevs x =
  map (λi. (i, pdevs_apply x i)) (rev (sorted_list_of_set (pdevs_domain x)))"

lemma list_of_pdevs_zero_pdevs[simp]: "list_of_pdevs zero_pdevs = []"
  by (auto simp: list_of_pdevs_def)

lemma sum_list_list_of_pdevs: "sum_list (map snd (list_of_pdevs x)) = sum_list (dense_list_of_pdevs x)"
  by (auto intro!: sum.mono_neutral_cong_left
    simp add: degree_gt sum_list_distinct_conv_sum_set dense_list_of_pdevs_def list_of_pdevs_def)

lemma sum_list_filter_dense_list_of_pdevs[symmetric]:
  "sum_list (map snd (filter (p o snd) (list_of_pdevs x))) =
    sum_list (filter p (dense_list_of_pdevs x))"
  by (auto intro!: sum.mono_neutral_cong_left
    simp add: degree_gt sum_list_distinct_conv_sum_set dense_list_of_pdevs_def list_of_pdevs_def
      o_def filter_map)

lemma pdevs_of_list_dense_list_of_pdevs: "pdevs_of_list (dense_list_of_pdevs x) = x"
  by (auto simp: pdevs_apply_pdevs_of_list dense_list_of_pdevs_def pdevs_eqI)

lemma pdevs_val_sum_list: "pdevs_val (λ_. c) X = c *⇩_R sum_list (map snd (list_of_pdevs X))"
  by (auto simp: pdevs_val_sum sum_list_list_of_pdevs pdevs_val_const_pdevs_of_list[symmetric]
    pdevs_of_list_dense_list_of_pdevs)

lemma list_of_pdevs_all_nonzero: "list_all (λx. x ≠ 0) (map snd (list_of_pdevs xs))"
  by (auto simp: list_of_pdevs_def list_all_iff)

lemma list_of_pdevs_nonzero: "x ∈ set (map snd (list_of_pdevs xs)) ⟹ x ≠ 0"
  by (auto simp: list_of_pdevs_def)

lemma pdevs_of_list_scaleR_0[simp]:
  fixes xs::"'a::real_vector list"
  shows "pdevs_of_list (map ((*⇩_R) 0) xs) = zero_pdevs"
  by (auto simp: pdevs_apply_pdevs_of_list intro!: pdevs_eqI)

lemma degree_pdevs_of_list_scaleR:
  "degree (pdevs_of_list (map ((*⇩_R) c) xs)) = (if c ≠ 0 then degree (pdevs_of_list xs) else 0)"
  by (auto simp: pdevs_apply_pdevs_of_list intro!: degree_cong)

lemma list_of_pdevs_eq:
  "rev (list_of_pdevs X) = (filter ((≠) 0 o snd) (map (λi. (i, pdevs_apply X i)) [0..<degree X]))"
  (is "_ = filter ?P (map ?f ?xs)")
  using map_filter[of ?f ?P ?xs]
  by (auto simp: list_of_pdevs_def o_def sorted_list_of_pdevs_domain_eq rev_map)

lemma sum_list_take_pdevs_val_eq:
  "sum_list (take d xs) = pdevs_val (λi. if i < d then 1 else 0) (pdevs_of_list xs)"
proof -
  have "sum_list (take d xs) = 1 *⇩_R sum_list (take d xs)" by simp
  also note pdevs_val_const_pdevs_of_list[symmetric]
  also have "pdevs_val (λ_. 1) (pdevs_of_list (take d xs)) =
      pdevs_val (λi. if i < d then 1 else 0) (pdevs_of_list xs)"
    by (auto simp: pdevs_apply_pdevs_of_list split: if_split_asm intro!: pdevs_val_eqI)
  finally show ?thesis .
qed

lemma zero_in_range_pdevs_apply[intro, simp]:
  fixes X::"'a::real_vector pdevs" shows "0 ∈ range (pdevs_apply X)"
  by (metis degree_gt less_irrefl rangeI)

lemma dense_list_in_range: "x ∈ set (dense_list_of_pdevs X) ⟹ x ∈ range (pdevs_apply X)"
  by (auto simp: dense_list_of_pdevs_def)

lemma not_in_dense_list_zeroD:
  assumes "pdevs_apply X i ∉ set (dense_list_of_pdevs X)"
  shows "pdevs_apply X i = 0"
proof (rule ccontr)
  assume "pdevs_apply X i ≠ 0"
  hence "i < degree X"
    by (rule degree_gt)
  thus False using assms
    by (auto simp: dense_list_of_pdevs_def)
qed

lemma list_all_list_of_pdevsI:
  assumes "⋀i. i ∈ pdevs_domain X ⟹ P (pdevs_apply X i)"
  shows "list_all (λx. P x) (map snd (list_of_pdevs X))"
  using assms by (auto simp: list_all_iff list_of_pdevs_def)

lemma pdevs_of_list_map_scaleR:
  "pdevs_of_list (map (scaleR r) xs) = scaleR_pdevs r (pdevs_of_list xs)"
  by (auto intro!: pdevs_eqI simp: pdevs_apply_pdevs_of_list)

lemma
  map_permI:
  assumes "xs <~~> ys"
  shows "map f xs <~~> map f ys"
  using assms by induct auto

lemma rev_perm: "rev xs <~~> ys ⟷ xs <~~> ys"
  by (metis perm.trans perm_rev rev_rev_ident)

lemma list_of_pdevs_perm_filter_nonzero:
  "map snd (list_of_pdevs X) <~~> (filter ((≠) 0) (dense_list_of_pdevs X))"
proof -
  have zip_map:
    "zip [0..<degree X] (dense_list_of_pdevs X) = map (λi. (i, pdevs_apply X i)) [0..<degree X]"
    by (auto simp: dense_list_of_pdevs_def intro!: nth_equalityI)
  have "rev (list_of_pdevs X) <~~>
      filter ((≠) 0 o snd) (zip [0..<degree X] (dense_list_of_pdevs X))"
    by (auto simp: list_of_pdevs_eq o_def zip_map)
  from map_permI[OF this, of snd]
  have "map snd (list_of_pdevs X) <~~>
      map snd (filter ((≠) 0 ∘ snd) (zip [0..<degree X] (dense_list_of_pdevs X)))"
    by (simp add: rev_map[symmetric] rev_perm)
  also have "map snd (filter ((≠) 0 ∘ snd) (zip [0..<degree X] (dense_list_of_pdevs X))) =
      filter ((≠) 0) (dense_list_of_pdevs X)"
    using map_filter[of snd "(≠) 0" "(zip [0..<degree X] (dense_list_of_pdevs X))"]
    by (simp add: o_def dense_list_of_pdevs_def)
   finally
   show ?thesis .
qed

lemma pdevs_val_filter:
  assumes mem: "e ∈ UNIV → I"
  assumes "0 ∈ I"
  obtains e' where
    "pdevs_val e (pdevs_of_list (filter p xs)) = pdevs_val e' (pdevs_of_list xs)"
    "e' ∈ UNIV → I"
  unfolding pdevs_val_filter_pdevs_eval
proof -
  have "(λ_::nat. 0) ∈ UNIV → I" using assms by simp
  have "pdevs_val e (pdevs_of_list (filter p xs)) =
      pdevs_val e (pdevs_of_list (filter p xs)) +
      pdevs_val (λ_. 0) (pdevs_of_list (filter (Not o p) xs))"
    by (simp add: pdevs_val_sum)
  also
  from pdevs_val_pdevs_of_list_append[OF ‹e ∈ _› ‹(λ_. 0) ∈ _›]
  obtain e' where "e' ∈ UNIV → I"
      "… = pdevs_val e' (pdevs_of_list (filter p xs @ filter (Not o p) xs))"
    by metis
  note this(2)
  also
  from pdevs_val_perm[OF partition_permI ‹e' ∈ _›]
  obtain e'' where "… = pdevs_val e'' (pdevs_of_list xs)" "e'' ∈ UNIV → I" by metis
  note this(1)
  finally show ?thesis using ‹e'' ∈ _› ..
qed

lemma
  pdevs_val_of_list_of_pdevs:
  assumes "e ∈ UNIV → I"
  assumes "0 ∈ I"
  obtains e' where
    "pdevs_val e (pdevs_of_list (map snd (list_of_pdevs X))) = pdevs_val e' X"
    "e' ∈ UNIV → I"
proof -
  obtain e' where "e' ∈ UNIV → I"
    and "pdevs_val e (pdevs_of_list (map snd (list_of_pdevs X))) =
      pdevs_val e' (pdevs_of_list (filter ((≠) 0) (dense_list_of_pdevs X)))"
    by (rule pdevs_val_perm[OF list_of_pdevs_perm_filter_nonzero assms(1)])
  note this(2)
  also from pdevs_val_filter[OF ‹e' ∈ _› ‹0 ∈ I›, of "(≠) 0" "dense_list_of_pdevs X"]
  obtain e'' where "e'' ∈ UNIV → I"
    and "… = pdevs_val e'' (pdevs_of_list (dense_list_of_pdevs X))"
    by metis
  note this(2)
  also have "… = pdevs_val e'' X" by (simp add: pdevs_of_list_dense_list_of_pdevs)
  finally show ?thesis using ‹e'' ∈ UNIV → I› ..
qed

lemma
  pdevs_val_of_list_of_pdevs2:
  assumes "e ∈ UNIV → I"
  obtains e' where
    "pdevs_val e X = pdevs_val e' (pdevs_of_list (map snd (list_of_pdevs X)))"
    "e' ∈ UNIV → I"
proof -
  from list_of_pdevs_perm_filter_nonzero[of X]
  have perm: "(filter ((≠) 0) (dense_list_of_pdevs X)) <~~> map snd (list_of_pdevs X)"
    by (simp add: perm_sym)
  have "pdevs_val e X = pdevs_val e (pdevs_of_list (dense_list_of_pdevs X))"
    by (simp add: pdevs_of_list_dense_list_of_pdevs)
  also from pdevs_val_partition[OF ‹e ∈ _›, of "dense_list_of_pdevs X" "(≠) 0"]
  obtain f g where "f ∈ UNIV → I" "g ∈ UNIV → I"
    "… = pdevs_val f (pdevs_of_list (filter ((≠) 0) (dense_list_of_pdevs X))) +
      pdevs_val g (pdevs_of_list (filter (Not ∘ (≠) 0) (dense_list_of_pdevs X)))"
    (is "_ = ?f + ?g")
    by metis
  note this(3)
  also
  have "pdevs_of_list [x←dense_list_of_pdevs X . x = 0] = zero_pdevs"
    by (auto intro!: pdevs_eqI simp: pdevs_apply_pdevs_of_list dest!: nth_mem)
  hence "?g = 0" by (auto simp: o_def )
  also
  obtain e' where "e' ∈ UNIV → I"
    and "?f = pdevs_val e' (pdevs_of_list (map snd (list_of_pdevs X)))"
    by (rule pdevs_val_perm[OF perm ‹f ∈ _›])
  note this(2)
  finally show ?thesis using ‹e' ∈ UNIV → I› by (auto intro!: that)
qed

lemma dense_list_of_pdevs_scaleR:
  "r ≠ 0 ⟹ map ((*⇩_R) r) (dense_list_of_pdevs x) = dense_list_of_pdevs (scaleR_pdevs r x)"
  by (auto simp: dense_list_of_pdevs_def)

lemma degree_pdevs_of_list_eq:
  "(⋀x. x ∈ set xs ⟹ x ≠ 0) ⟹ degree (pdevs_of_list xs) = length xs"
  by (cases xs) (auto simp add: pdevs_apply_pdevs_of_list nth_Cons
    intro!: degree_eqI
    split: nat.split)

lemma dense_list_of_pdevs_pdevs_of_list:
  "(⋀x. x ∈ set xs ⟹ x ≠ 0) ⟹ dense_list_of_pdevs (pdevs_of_list xs) = xs"
  by (auto simp: dense_list_of_pdevs_def degree_pdevs_of_list_eq pdevs_apply_pdevs_of_list
    intro!: nth_equalityI)

lemma pdevs_of_list_sum:
  assumes "distinct xs"
  assumes "e ∈ UNIV → I"
  obtains f where "f ∈ UNIV → I" "pdevs_val e (pdevs_of_list xs) = (∑P∈set xs. f P *⇩_R P)"
proof -
  define f where "f X = e (the (map_of (zip xs [0..<length xs]) X))" for X
  from assms have "f ∈ UNIV → I"
    by (auto simp: f_def)
  moreover
  have "pdevs_val e (pdevs_of_list xs) = (∑P∈set xs. f P *⇩_R P)"
    by (auto simp add: pdevs_val_zip f_def assms sum_list_distinct_conv_sum_set[symmetric]
      in_set_zip map_of_zip_upto2_length_eq_nth
      intro!: sum_list_nth_eqI)
  ultimately show ?thesis ..
qed

lemma pdevs_domain_eq_pdevs_of_list:
  assumes nz: "⋀x. x ∈ set (xs) ⟹ x ≠ 0"
  shows "pdevs_domain (pdevs_of_list xs) = {0..<length xs}"
  using nz
  by (auto simp: pdevs_apply_pdevs_of_list split: if_split_asm)

lemma length_list_of_pdevs_pdevs_of_list:
  assumes nz: "⋀x. x ∈ set xs ⟹ x ≠ 0"
  shows "length (list_of_pdevs (pdevs_of_list xs)) = length xs"
  using nz by (auto simp: list_of_pdevs_def pdevs_domain_eq_pdevs_of_list)

lemma nth_list_of_pdevs_pdevs_of_list:
  assumes nz: "⋀x. x ∈ set xs ⟹ x ≠ 0"
  assumes l: "n < length xs"
  shows "list_of_pdevs (pdevs_of_list xs) ! n  = ((length xs - Suc n), xs ! (length xs - Suc n))"
  using nz l
  by (auto simp: list_of_pdevs_def pdevs_domain_eq_pdevs_of_list rev_nth pdevs_apply_pdevs_of_list)

lemma list_of_pdevs_pdevs_of_list_eq:
  "(⋀x. x ∈ set xs ⟹ x ≠ 0) ⟹
    list_of_pdevs (pdevs_of_list xs) = zip (rev [0..<length xs]) (rev xs)"
  by (auto simp: nth_list_of_pdevs_pdevs_of_list length_list_of_pdevs_pdevs_of_list rev_nth
    intro!: nth_equalityI)

lemma sum_list_filter_list_of_pdevs_of_list:
  fixes xs::"'a::comm_monoid_add list"
  assumes "⋀x. x ∈ set xs ⟹ x ≠ 0"
  shows "sum_list (filter p (map snd (list_of_pdevs (pdevs_of_list xs)))) = sum_list (filter p xs)"
  using assms
  by (auto simp: list_of_pdevs_pdevs_of_list_eq rev_filter[symmetric])

lemma
  sum_list_partition:
  fixes xs::"'a::comm_monoid_add list"
  shows "sum_list (filter p xs) + sum_list (filter (Not o p) xs) = sum_list xs"
  by (induct xs) (auto simp: ac_simps)


subsection ‹2d zonotopes›

definition "prod_of_pdevs x y = binop_pdevs Pair x y"

lemma apply_pdevs_prod_of_pdevs[simp]:
  "pdevs_apply (prod_of_pdevs x y) i = (pdevs_apply x i, pdevs_apply y i)"
  unfolding prod_of_pdevs_def
  by (simp add: zero_prod_def)

lemma pdevs_domain_prod_of_pdevs[simp]:
  "pdevs_domain (prod_of_pdevs x y) = pdevs_domain x ∪ pdevs_domain y"
  by (auto simp: zero_prod_def)

lemma pdevs_val_prod_of_pdevs[simp]:
  "pdevs_val e (prod_of_pdevs x y) = (pdevs_val e x, pdevs_val e y)"
proof -
  have "pdevs_val e x = (∑i∈pdevs_domain x ∪ pdevs_domain y. e i *⇩_R pdevs_apply x i)"
    (is "_ = ?x")
    unfolding pdevs_val_pdevs_domain
    by (rule sum.mono_neutral_cong_left) auto
  moreover have "pdevs_val e y = (∑i∈pdevs_domain x ∪ pdevs_domain y. e i *⇩_R pdevs_apply y i)"
    (is "_ = ?y")
    unfolding pdevs_val_pdevs_domain
    by (rule sum.mono_neutral_cong_left) auto
  ultimately have "(pdevs_val e x, pdevs_val e y) = (?x, ?y)"
    by auto
  also have "… = pdevs_val e (prod_of_pdevs x y)"
    by (simp add: sum_prod pdevs_val_pdevs_domain)
  finally show ?thesis by simp
qed

definition prod_of_aforms (infixr "×⇩_a" 80)
  where "prod_of_aforms x y = ((fst x, fst y), prod_of_pdevs (snd x) (snd y))"


subsection ‹Intervals›

definition One_pdevs_raw::"nat ⇒ 'a::executable_euclidean_space"
  where "One_pdevs_raw i = (if i < length (Basis_list::'a list) then Basis_list ! i else 0)"

lemma zeros_One_pdevs_raw:
  "One_pdevs_raw -` {0::'a::executable_euclidean_space} = {length (Basis_list::'a list)..}"
  by (auto simp: One_pdevs_raw_def nonzero_Basis split: if_split_asm dest!: nth_mem)

lemma nonzeros_One_pdevs_raw:
  "{i. One_pdevs_raw i ≠ (0::'a::executable_euclidean_space)} = - {length (Basis_list::'a list)..}"
  using zeros_One_pdevs_raw
  by blast

lift_definition One_pdevs::"'a::executable_euclidean_space pdevs" is One_pdevs_raw
  by (auto simp: nonzeros_One_pdevs_raw)

lemma pdevs_apply_One_pdevs[simp]: "pdevs_apply One_pdevs i =
  (if i < length (Basis_list::'a::executable_euclidean_space list) then Basis_list ! i else 0::'a)"
  by transfer (simp add: One_pdevs_raw_def)

lemma Max_Collect_less_nat: "Max {i::nat. i < k} = (if k = 0 then Max {} else k - 1)"
  by (auto intro!: Max_eqI)

lemma degree_One_pdevs[simp]: "degree (One_pdevs::'a pdevs) =
    length (Basis_list::'a::executable_euclidean_space list)"
  by (auto simp: degree_eq_Suc_max Basis_list_nth_nonzero Max_Collect_less_nat
      intro!: Max_eqI DIM_positive)

definition inner_scaleR_pdevs::"'a::euclidean_space ⇒ 'a pdevs ⇒ 'a pdevs"
  where "inner_scaleR_pdevs b x = unop_pdevs (λx. (b ∙ x) *⇩_R x) x"

lemma pdevs_apply_inner_scaleR_pdevs[simp]:
  "pdevs_apply (inner_scaleR_pdevs a x) i = (a ∙ (pdevs_apply x i)) *⇩_R (pdevs_apply x i)"
  by (simp add: inner_scaleR_pdevs_def)

lemma degree_inner_scaleR_pdevs_le:
  "degree (inner_scaleR_pdevs (l::'a::executable_euclidean_space) One_pdevs) ≤
    degree (One_pdevs::'a pdevs)"
  by (rule degree_leI) (auto simp: inner_scaleR_pdevs_def One_pdevs_raw_def)

definition "pdevs_of_ivl l u = scaleR_pdevs (1/2) (inner_scaleR_pdevs (u - l) One_pdevs)"

lemma degree_pdevs_of_ivl_le:
  "degree (pdevs_of_ivl l u::'a::executable_euclidean_space pdevs) ≤ DIM('a)"
  using degree_inner_scaleR_pdevs_le
  by (simp add: pdevs_of_ivl_def)

lemma pdevs_apply_pdevs_of_ivl:
  defines "B ≡ Basis_list::'a::executable_euclidean_space list"
  shows "pdevs_apply (pdevs_of_ivl l u) i = (if i < length B then ((u - l)∙(B!i)/2)*⇩_R(B!i) else 0)"
  by (auto simp: pdevs_of_ivl_def B_def)

lemma deg_length_less_imp[simp]:
  "k < degree (pdevs_of_ivl l u::'a::executable_euclidean_space pdevs) ⟹
    k < length (Basis_list::'a list)"
  by (metis (no_types, hide_lams) degree_One_pdevs degree_inner_scaleR_pdevs_le degree_scaleR_pdevs
      dual_order.strict_trans length_Basis_list_pos nat_neq_iff not_le pdevs_of_ivl_def)

lemma tdev_pdevs_of_ivl: "tdev (pdevs_of_ivl l u) = ¦u - l¦ /⇩_R 2"
proof -
  have "tdev (pdevs_of_ivl l u) =
    (∑i <degree (pdevs_of_ivl l u). ¦pdevs_apply (pdevs_of_ivl l u) i¦)"
    by (auto simp: tdev_def)
  also have "… = (∑i = 0..<length (Basis_list::'a list). ¦pdevs_apply (pdevs_of_ivl l u) i¦)"
    using degree_pdevs_of_ivl_le[of l u]
    by (intro sum.mono_neutral_cong_left) auto
  also have "… = (∑i = 0..<length (Basis_list::'a list).
      ¦((u - l) ∙ Basis_list ! i / 2) *⇩_R Basis_list ! i¦)"
    by (auto simp: pdevs_apply_pdevs_of_ivl)
  also have "… = (∑b ← Basis_list. ¦((u - l) ∙ b / 2) *⇩_R b¦)"
    by (auto simp: sum_list_sum_nth)
  also have "… = (∑b∈Basis. ¦((u - l) ∙ b / 2) *⇩_R b¦)"
    by (auto simp: sum_list_distinct_conv_sum_set)
  also have "… = ¦u - l¦ /⇩_R 2"
    by (subst euclidean_representation[symmetric, of "¦u - l¦ /⇩_R 2"])
      (simp add:  abs_inner abs_scaleR)
  finally show ?thesis .
qed

definition "aform_of_ivl l u = ((l + u)/⇩_R2, pdevs_of_ivl l u)"

definition "aform_of_point x = aform_of_ivl x x"

lemma Elem_affine_of_ivl_le:
  assumes "e ∈ UNIV → {-1 .. 1}"
  assumes "l ≤ u"
  shows "l ≤ aform_val e (aform_of_ivl l u)"
proof -
  have "l =  (1 / 2) *⇩_R l + (1 / 2) *⇩_R l"
    by (simp add: scaleR_left_distrib[symmetric])
  also have "… = (l + u)/⇩_R2 - tdev (pdevs_of_ivl l u)"
    by (auto simp: assms tdev_pdevs_of_ivl algebra_simps)
  also have "… ≤ aform_val e (aform_of_ivl l u)"
    using abs_pdevs_val_le_tdev[OF assms(1), of "pdevs_of_ivl l u"]
    by (auto simp: aform_val_def aform_of_ivl_def minus_le_iff dest!: abs_le_D2)
  finally show ?thesis .
qed

lemma Elem_affine_of_ivl_ge:
  assumes "e ∈ UNIV → {-1 .. 1}"
  assumes "l ≤ u"
  shows "aform_val e (aform_of_ivl l u) ≤ u"
proof -
  have "aform_val e (aform_of_ivl l u) ≤  (l + u)/⇩_R2 + tdev (pdevs_of_ivl l u)"
    using abs_pdevs_val_le_tdev[OF assms(1), of "pdevs_of_ivl l u"]
    by (auto simp: aform_val_def aform_of_ivl_def minus_le_iff dest!: abs_le_D1)
  also have "… = (1 / 2) *⇩_R u + (1 / 2) *⇩_R u"
    by (auto simp: assms tdev_pdevs_of_ivl algebra_simps)
  also have "… = u"
    by (simp add: scaleR_left_distrib[symmetric])
  finally show ?thesis .
qed

lemma
  map_of_zip_upto_length_eq_nth:
  assumes "i < length B"
  assumes "d = length B"
  shows "(map_of (zip [0..<d] B) i) = Some (B ! i)"
proof -
  have "length [0..<length B] = length B"
    by simp
  from map_of_zip_is_Some[OF this, of i] assms
  have "map_of (zip [0..<length B] B) i = Some (B ! i)"
    by (auto simp: in_set_zip)
  thus ?thesis by (simp add: assms)
qed

lemma in_ivl_affine_of_ivlE:
  assumes "k ∈ {l .. u}"
  obtains e where "e ∈ UNIV → {-1 .. 1}" "k = aform_val e (aform_of_ivl l u)"
proof atomize_elim
  define e where [abs_def]: "e i = (let b = if i <length (Basis_list::'a list) then
    (the (map_of (zip [0..<length (Basis_list::'a list)] (Basis_list::'a list)) i)) else 0 in
      ((k - (l + u) /⇩_R 2) ∙ b) / (((u - l) /⇩_R 2) ∙ b))" for i
  let ?B = "Basis_list::'a list"

  have "k = (1 / 2) *⇩_R (l + u) +
      (∑b ∈ Basis. (if (u - l) ∙ b = 0 then 0 else ((k - (1 / 2) *⇩_R (l + u)) ∙ b)) *⇩_R b)"
    (is "_ = _ + ?dots")
    using assms
    by (force simp add: algebra_simps eucl_le[where 'a='a] intro!: euclidean_eqI[where 'a='a])
  also have
    "?dots = (∑b ∈ Basis. (if (u - l) ∙ b = 0 then 0 else ((k - (1 / 2) *⇩_R (l + u)) ∙ b) *⇩_R b))"
    by (auto intro!: sum.cong)
  also have "… = (∑b ← ?B. (if (u - l) ∙ b = 0 then 0 else ((k - (1 / 2) *⇩_R (l + u)) ∙ b) *⇩_R b))"
    by (auto simp: sum_list_distinct_conv_sum_set)
  also have "… =
    (∑i = 0..<length ?B.
        (if (u - l) ∙ ?B ! i = 0 then 0 else ((k - (1 / 2) *⇩_R (l + u)) ∙ ?B ! i) *⇩_R ?B ! i))"
    by (auto simp: sum_list_sum_nth)
  also have "… =
    (∑i = 0..<degree (inner_scaleR_pdevs (u - l) One_pdevs).
        (if (u - l) ∙ Basis_list ! i = 0 then 0
        else ((k - (1 / 2) *⇩_R (l + u)) ∙ Basis_list ! i) *⇩_R Basis_list ! i))"
    using degree_inner_scaleR_pdevs_le[of "u - l"]
    by (intro sum.mono_neutral_cong_right) (auto dest!: degree)
  also have "(1 / 2) *⇩_R (l + u) +
    (∑i = 0..<degree (inner_scaleR_pdevs (u - l) One_pdevs).
        (if (u - l) ∙ Basis_list ! i = 0 then 0
        else ((k - (1 / 2) *⇩_R (l + u)) ∙ Basis_list ! i) *⇩_R Basis_list ! i)) =
      aform_val e (aform_of_ivl l u)"
    using degree_inner_scaleR_pdevs_le[of "u - l"]
    by (auto simp: aform_val_def aform_of_ivl_def pdevs_of_ivl_def map_of_zip_upto_length_eq_nth
      e_def Let_def pdevs_val_sum
      intro!: sum.cong)
  finally have "k = aform_val e (aform_of_ivl l u)" .

  moreover
  {
    fix k l u::real assume *: "l ≤ k" "k ≤ u"
    let ?m = "l / 2 + u / 2"
    have "¦k - ?m¦ ≤ ¦if k ≤ ?m then ?m - l else u - ?m¦"
      using * by auto
    also have "… ≤ ¦u / 2 - l / 2¦"
      by (auto simp: abs_real_def)
    finally have "¦k - (l / 2 + u / 2)¦ ≤ ¦u / 2 - l/2¦" .
  } note midpoint_abs = this
  have "e ∈ UNIV → {- 1..1}"
    using assms
    unfolding e_def Let_def
    by (intro Pi_I divide_atLeastAtMost_1_absI)
      (auto simp: map_of_zip_upto_length_eq_nth eucl_le[where 'a='a]
        divide_le_eq_1 not_less inner_Basis algebra_simps intro!: midpoint_abs
        dest!: nth_mem)
  ultimately show "∃e. e ∈ UNIV → {- 1..1} ∧ k = aform_val e (aform_of_ivl l u)"
    by blast
qed

lemma Inf_aform_aform_of_ivl:
  assumes "l ≤ u"
  shows "Inf_aform (aform_of_ivl l u) = l"
  using assms
  by (auto simp: Inf_aform_def aform_of_ivl_def tdev_pdevs_of_ivl abs_diff_eq1 algebra_simps)
    (metis field_sum_of_halves scaleR_add_left scaleR_one)

lemma Sup_aform_aform_of_ivl:
  assumes "l ≤ u"
  shows "Sup_aform (aform_of_ivl l u) = u"
  using assms
  by (auto simp: Sup_aform_def aform_of_ivl_def tdev_pdevs_of_ivl abs_diff_eq1 algebra_simps)
    (metis field_sum_of_halves scaleR_add_left scaleR_one)

lemma Affine_aform_of_ivl:
  "a ≤ b ⟹ Affine (aform_of_ivl a b) = {a .. b}"
  by (force simp: Affine_def valuate_def intro!: Elem_affine_of_ivl_ge Elem_affine_of_ivl_le
    elim!: in_ivl_affine_of_ivlE)

end

Theory Floatarith_Expression

section ‹Operations on Expressions›
theory Floatarith_Expression
imports
  "HOL-Decision_Procs.Approximation"
  Affine_Arithmetic_Auxiliarities
  Executable_Euclidean_Space
begin

text ‹Much of this could move to the distribution...›

subsection ‹Approximating Expression*s*›

unbundle floatarith_notation

text ‹\label{sec:affineexpr}›

primrec interpret_floatariths :: "floatarith list ⇒ real list ⇒ real list"
where
    "interpret_floatariths [] vs = []"
  | "interpret_floatariths (a#bs) vs = interpret_floatarith a vs#interpret_floatariths bs vs"

lemma length_interpret_floatariths[simp]: "length (interpret_floatariths fas xs) = length fas"
  by (induction fas) auto

lemma interpret_floatariths_nth[simp]:
  "interpret_floatariths fas xs ! n = interpret_floatarith (fas ! n) xs"
  if "n < length fas"
  using that
  by (induction fas arbitrary: n) (auto simp: nth_Cons split: nat.splits)

abbreviation "einterpret ≡ λfas vs. eucl_of_list (interpret_floatariths fas vs)"

subsection ‹Syntax›

syntax interpret_floatarith::"floatarith ⇒ real list ⇒ real"

instantiation floatarith :: "{plus, minus, uminus, times, inverse, zero, one}"
begin

definition "- f = Minus f"
lemma interpret_floatarith_uminus[simp]:
  "interpret_floatarith (- f) xs = - interpret_floatarith f xs"
  by (auto simp: uminus_floatarith_def)

definition "f + g = Add f g"
lemma interpret_floatarith_plus[simp]:
  "interpret_floatarith (f + g) xs = interpret_floatarith f xs + interpret_floatarith g xs"
  by (auto simp: plus_floatarith_def)

definition "f - g = Add f (Minus g)"
lemma interpret_floatarith_minus[simp]:
  "interpret_floatarith (f - g) xs = interpret_floatarith f xs - interpret_floatarith g xs"
  by (auto simp: minus_floatarith_def)

definition "inverse f = Inverse f"
lemma interpret_floatarith_inverse[simp]:
  "interpret_floatarith (inverse f) xs = inverse (interpret_floatarith f xs)"
  by (auto simp: inverse_floatarith_def)

definition "f * g = Mult f g"
lemma interpret_floatarith_times[simp]:
  "interpret_floatarith (f * g) xs = interpret_floatarith f xs * interpret_floatarith g xs"
  by (auto simp: times_floatarith_def)

definition "f div g = f * Inverse g"
lemma interpret_floatarith_divide[simp]:
  "interpret_floatarith (f div g) xs = interpret_floatarith f xs / interpret_floatarith g xs"
  by (auto simp: divide_floatarith_def inverse_eq_divide)

definition "1 = Num 1"
lemma interpret_floatarith_one[simp]:
  "interpret_floatarith 1 xs = 1"
  by (auto simp: one_floatarith_def)

definition "0 = Num 0"
lemma interpret_floatarith_zero[simp]:
  "interpret_floatarith 0 xs = 0"
  by (auto simp: zero_floatarith_def)

instance proof qed
end


subsection ‹Derived symbols›

definition "R⇩_e r = (case quotient_of r of (n, d) ⇒ Num (of_int n) / Num (of_int d))"
declare [[coercion R⇩_e ]]

lemma interpret_R⇩_e[simp]: "interpret_floatarith (R⇩_e x) xs = real_of_rat x"
  by (auto simp: R⇩_e_def of_rat_divide dest!: quotient_of_div split: prod.splits)

definition "Sin x = Cos ((Pi * (Num (Float 1 (-1)))) - x)"

lemma interpret_floatarith_Sin[simp]:
  "interpret_floatarith (Sin x) vs = sin (interpret_floatarith x vs)"
  by (auto simp: Sin_def approximation_preproc_floatarith(11))

definition "Half x = Mult (Num (Float 1 (-1))) x"
lemma interpret_Half[simp]: "interpret_floatarith (Half x) xs = interpret_floatarith x xs / 2"
  by (auto simp: Half_def)

definition "Tan x = (Sin x) / (Cos x)"

lemma interpret_floatarith_Tan[simp]:
  "interpret_floatarith (Tan x) vs = tan (interpret_floatarith x vs)"
  by (auto simp: Tan_def approximation_preproc_floatarith(12) inverse_eq_divide)

primrec Sum⇩_e where
  "Sum⇩_e f [] = 0"
| "Sum⇩_e f (x#xs) = f x + Sum⇩_e f xs" 

lemma interpret_floatarith_Sum⇩_e[simp]:
  "interpret_floatarith (Sum⇩_e f x) vs = (∑i←x. interpret_floatarith (f i) vs)"
  by (induction x) auto

definition Norm where "Norm is = Sqrt (Sum⇩_e (λi. i * i) is)"

lemma interpret_floatarith_norm[simp]:
  assumes [simp]: "length x = DIM('a)"
  shows "interpret_floatarith (Norm x) vs = norm (einterpret x vs::'a::executable_euclidean_space)"
  apply (auto simp: Norm_def norm_eq_sqrt_inner)
  apply (subst euclidean_inner[where 'a='a])
  apply (auto simp: power2_eq_square[symmetric] )
  apply (subst sum_list_Basis_list[symmetric])
  apply (rule sum_list_nth_eqI)
  by (auto simp: in_set_zip eucl_of_list_inner)

notation floatarith.Power (infixr "^⇩_e" 80)

subsection ‹Constant Folding›

fun dest_Num_fa where
  "dest_Num_fa (floatarith.Num x) = Some x"
| "dest_Num_fa _ = None"

fun_cases dest_Num_fa_None: "dest_Num_fa fa = None"
  and dest_Num_fa_Some: "dest_Num_fa fa = Some x"

fun fold_const_fa where
  "fold_const_fa (Add fa1 fa2) =
    (let (ffa1, ffa2) = (fold_const_fa fa1, fold_const_fa fa2)
    in case (dest_Num_fa ffa1, dest_Num_fa (ffa2)) of
      (Some a, Some b) ⇒ Num (a + b)
    | (Some a, None) ⇒ (if a = 0 then ffa2 else Add (Num a) ffa2)
    | (None, Some a) ⇒ (if a = 0 then ffa1 else Add ffa1 (Num a))
    | (None, None) ⇒ Add ffa1 ffa2)"
| "fold_const_fa (Minus a) =
    (case (fold_const_fa a) of
      (Num x) ⇒ Num (-x)
    | x ⇒ Minus x)"
| "fold_const_fa (Mult fa1 fa2) =
    (let (ffa1, ffa2) = (fold_const_fa fa1, fold_const_fa fa2)
  in case (dest_Num_fa ffa1, dest_Num_fa (ffa2)) of
    (Some a, Some b) ⇒ Num (a * b)
  | (Some a, None) ⇒ (if a = 0 then Num 0 else if a = 1 then ffa2 else Mult (Num a) ffa2)
  | (None, Some a) ⇒ (if a = 0 then Num 0 else if a = 1 then ffa1 else Mult ffa1 (Num a))
  | (None, None) ⇒ Mult ffa1 ffa2)"
| "fold_const_fa (Inverse a) = Inverse (fold_const_fa a)"
| "fold_const_fa (Abs a) =
    (case (fold_const_fa a) of
      (Num x) ⇒ Num (abs x)
    | x ⇒ Abs x)"
| "fold_const_fa (Max a b) =
    (case (fold_const_fa a, fold_const_fa b) of
      (Num x, Num y) ⇒ Num (max x y)
    | (x, y) ⇒ Max x y)"
| "fold_const_fa (Min a b) =
    (case (fold_const_fa a, fold_const_fa b) of
      (Num x, Num y) ⇒ Num (min x y)
    | (x, y) ⇒ Min x y)"
| "fold_const_fa (Floor a) =
    (case (fold_const_fa a) of
      (Num x) ⇒ Num (floor_fl x)
    | x ⇒ Floor x)"
| "fold_const_fa (Power a b) =
    (case (fold_const_fa a) of
      (Num x) ⇒ Num (x ^ b)
    | x ⇒ Power x b)"
| "fold_const_fa (Cos a) = Cos (fold_const_fa a)"
| "fold_const_fa (Arctan a) = Arctan (fold_const_fa a)"
| "fold_const_fa (Sqrt a) = Sqrt (fold_const_fa a)"
| "fold_const_fa (Exp a) = Exp (fold_const_fa a)"
| "fold_const_fa (Ln a) = Ln (fold_const_fa a)"
| "fold_const_fa (Powr a b) = Powr (fold_const_fa a) (fold_const_fa b)"
| "fold_const_fa Pi = Pi"
| "fold_const_fa (Var v) = Var v"
| "fold_const_fa (Num x) = Num x"

fun_cases fold_const_fa_Num: "fold_const_fa fa = Num y"
  and fold_const_fa_Add: "fold_const_fa fa = Add x y"
  and fold_const_fa_Minus: "fold_const_fa fa = Minus y"

lemma fold_const_fa[simp]: "interpret_floatarith (fold_const_fa fa) xs = interpret_floatarith fa xs"
  by (induction fa) (auto split!: prod.splits floatarith.splits option.splits
      elim!: dest_Num_fa_None dest_Num_fa_Some
      simp: max_def min_def floor_fl_def)


subsection ‹Free Variables›

primrec max_Var_floatarith where― ‹TODO: include bound in predicate›
  "max_Var_floatarith (Add a b) = max (max_Var_floatarith a) (max_Var_floatarith b)"
| "max_Var_floatarith (Mult a b) = max (max_Var_floatarith a) (max_Var_floatarith b)"
| "max_Var_floatarith (Inverse a) = max_Var_floatarith a"
| "max_Var_floatarith (Minus a) = max_Var_floatarith a"
| "max_Var_floatarith (Num a) = 0"
| "max_Var_floatarith (Var i) = Suc i"
| "max_Var_floatarith (Cos a) = max_Var_floatarith a"
| "max_Var_floatarith (floatarith.Arctan a) = max_Var_floatarith a"
| "max_Var_floatarith (Abs a) = max_Var_floatarith a"
| "max_Var_floatarith (floatarith.Max a b) = max (max_Var_floatarith a) (max_Var_floatarith b)"
| "max_Var_floatarith (floatarith.Min a b) = max (max_Var_floatarith a) (max_Var_floatarith b)"
| "max_Var_floatarith (floatarith.Pi) = 0"
| "max_Var_floatarith (Sqrt a) = max_Var_floatarith a"
| "max_Var_floatarith (Exp a) = max_Var_floatarith a"
| "max_Var_floatarith (Powr a b) = max (max_Var_floatarith a) (max_Var_floatarith b)"
| "max_Var_floatarith (floatarith.Ln a) = max_Var_floatarith a"
| "max_Var_floatarith (Power a n) = max_Var_floatarith a"
| "max_Var_floatarith (Floor a) = max_Var_floatarith a"       
  
primrec max_Var_floatariths where
  "max_Var_floatariths [] = 0"
| "max_Var_floatariths (x#xs) = max (max_Var_floatarith x) (max_Var_floatariths xs)"

primrec max_Var_form where
  "max_Var_form (Conj a b) = max (max_Var_form a) (max_Var_form b)"
|  "max_Var_form (Disj a b) = max (max_Var_form a) (max_Var_form b)"
|  "max_Var_form (Less a b) = max (max_Var_floatarith a) (max_Var_floatarith b)"
|  "max_Var_form (LessEqual a b) = max (max_Var_floatarith a) (max_Var_floatarith b)"
|  "max_Var_form (Bound a b c d) = linorder_class.Max {max_Var_floatarith a,max_Var_floatarith b, max_Var_floatarith c, max_Var_form d}"
|  "max_Var_form (AtLeastAtMost a b c) = linorder_class.Max {max_Var_floatarith a,max_Var_floatarith b, max_Var_floatarith c}"
|  "max_Var_form (Assign a b c) = linorder_class.Max {max_Var_floatarith a,max_Var_floatarith b, max_Var_form c}"

lemma
  interpret_floatarith_eq_take_max_VarI:
  assumes "take (max_Var_floatarith ra) ys = take (max_Var_floatarith ra) zs"
  shows "interpret_floatarith ra ys = interpret_floatarith ra zs"
  using assms
  by (induct ra) (auto dest!: take_max_eqD simp: take_Suc_eq split: if_split_asm)

lemma
  interpret_floatariths_eq_take_max_VarI:
  assumes "take (max_Var_floatariths ea) ys = take (max_Var_floatariths ea) zs"
  shows "interpret_floatariths ea ys = interpret_floatariths ea zs"
  using assms
  apply (induction ea)
  subgoal by simp
  subgoal by (clarsimp) (metis interpret_floatarith_eq_take_max_VarI take_map take_max_eqD)
  done


lemma Max_Image_distrib:
  includes no_floatarith_notation
  assumes "finite X" "X ≠ {}"
  shows "Max ((λx. max (f1 x) (f2 x)) ` X) = max (Max (f1 ` X)) (Max (f2 ` X))"
  apply (rule Max_eqI)
  subgoal using assms by simp
  subgoal for y
    using assms
    by (force intro: max.coboundedI1 max.coboundedI2 Max_ge)
  subgoal
  proof -
    have "Max (f1 ` X) ∈ f1 ` X" using assms by auto
    then obtain x1 where x1: "x1 ∈ X" "Max (f1 ` X) = f1 x1" by auto
    have "Max (f2 ` X) ∈ f2 ` X" using assms by auto
    then obtain x2 where x2: "x2 ∈ X" "Max (f2 ` X) = f2 x2" by auto
    show ?thesis
      apply (rule image_eqI[where x="if f1 x1 ≤ f2 x2 then x2 else x1"])
      using x1 x2 assms
       apply (auto simp: max_def)
       apply (metis Max_ge dual_order.trans finite_imageI image_eqI assms(1))
      apply (metis Max_ge dual_order.trans finite_imageI image_eqI assms(1))
      done
  qed
  done

lemma max_Var_floatarith_simps[simp]:
  "max_Var_floatarith (a / b) = max (max_Var_floatarith a) (max_Var_floatarith b)"
  "max_Var_floatarith (a * b) = max (max_Var_floatarith a) (max_Var_floatarith b)"
  "max_Var_floatarith (a + b) = max (max_Var_floatarith a) (max_Var_floatarith b)"
  "max_Var_floatarith (a - b) = max (max_Var_floatarith a) (max_Var_floatarith b)"
  "max_Var_floatarith (- b) = (max_Var_floatarith b)"
  by (auto simp: divide_floatarith_def times_floatarith_def plus_floatarith_def minus_floatarith_def
      uminus_floatarith_def)

lemma max_Var_floatariths_Max:
  "max_Var_floatariths xs = (if set xs = {} then 0 else linorder_class.Max (max_Var_floatarith ` set xs))"
  by (induct xs) auto


lemma max_Var_floatariths_map_plus[simp]:
  "max_Var_floatariths (map (λi. fa1 i + fa2 i) xs) = max (max_Var_floatariths (map fa1 xs)) (max_Var_floatariths (map fa2 xs))"
  by (auto simp: max_Var_floatariths_Max image_image Max_Image_distrib)

lemma max_Var_floatariths_map_times[simp]:
  "max_Var_floatariths (map (λi. fa1 i * fa2 i) xs) = max (max_Var_floatariths (map fa1 xs)) (max_Var_floatariths (map fa2 xs))"
  by (auto simp: max_Var_floatariths_Max image_image Max_Image_distrib)

lemma max_Var_floatariths_map_divide[simp]:
  "max_Var_floatariths (map (λi. fa1 i / fa2 i) xs) = max (max_Var_floatariths (map fa1 xs)) (max_Var_floatariths (map fa2 xs))"
  by (auto simp: max_Var_floatariths_Max image_image Max_Image_distrib)

lemma max_Var_floatariths_map_uminus[simp]:
  "max_Var_floatariths (map (λi. - fa1 i) xs) = max_Var_floatariths (map fa1 xs)"
  by (auto simp: max_Var_floatariths_Max image_image Max_Image_distrib)

lemma max_Var_floatariths_map_const[simp]:
  "max_Var_floatariths (map (λi. fa) xs) = (if xs = [] then 0 else max_Var_floatarith fa)"
  by (auto simp: max_Var_floatariths_Max image_image image_constant_conv)

lemma max_Var_floatariths_map_minus[simp]:
  "max_Var_floatariths (map (λi. fa1 i - fa2 i) xs) = max (max_Var_floatariths (map fa1 xs)) (max_Var_floatariths (map fa2 xs))"
  by (auto simp: max_Var_floatariths_Max image_image Max_Image_distrib)


primrec fresh_floatarith where
  "fresh_floatarith (Var y) x ⟷ (x ≠ y)"
| "fresh_floatarith (Num a) x ⟷ True"
| "fresh_floatarith Pi x ⟷ True"
| "fresh_floatarith (Cos a) x ⟷ fresh_floatarith a x"
| "fresh_floatarith (Abs a) x ⟷ fresh_floatarith a x"
| "fresh_floatarith (Arctan a) x ⟷ fresh_floatarith a x"
| "fresh_floatarith (Sqrt a) x ⟷ fresh_floatarith a x"
| "fresh_floatarith (Exp a) x ⟷ fresh_floatarith a x"
| "fresh_floatarith (Floor a) x ⟷ fresh_floatarith a x"
| "fresh_floatarith (Power a n) x ⟷ fresh_floatarith a x"
| "fresh_floatarith (Minus a) x ⟷ fresh_floatarith a x"
| "fresh_floatarith (Ln a) x ⟷ fresh_floatarith a x"
| "fresh_floatarith (Inverse a) x ⟷ fresh_floatarith a x"
| "fresh_floatarith (Add a b) x ⟷ fresh_floatarith a x ∧ fresh_floatarith b x"
| "fresh_floatarith (Mult a b) x ⟷ fresh_floatarith a x ∧ fresh_floatarith b x"
| "fresh_floatarith (Max a b) x ⟷ fresh_floatarith a x ∧ fresh_floatarith b x"
| "fresh_floatarith (Min a b) x ⟷ fresh_floatarith a x ∧ fresh_floatarith b x"
| "fresh_floatarith (Powr a b) x ⟷ fresh_floatarith a x ∧ fresh_floatarith b x"

lemma fresh_floatarith_subst:
  fixes v::float
  assumes "fresh_floatarith e x"
  assumes "x < length vs"
  shows "interpret_floatarith e (vs[x:=v]) = interpret_floatarith e vs"
  using assms
  by (induction e) (auto simp: map_update)

lemma fresh_floatarith_max_Var:
  assumes "max_Var_floatarith ea ≤ i"
  shows "fresh_floatarith ea i"
  using assms
  by (induction ea) auto

primrec fresh_floatariths where
  "fresh_floatariths [] x ⟷ True"
| "fresh_floatariths (a#as) x ⟷ fresh_floatarith a x ∧ fresh_floatariths as x"

lemma fresh_floatariths_max_Var:
  assumes "max_Var_floatariths ea ≤ i"
  shows "fresh_floatariths ea i"
  using assms
  by (induction ea) (auto simp: fresh_floatarith_max_Var)

lemma
  interpret_floatariths_take_eqI:
  assumes "take n ys = take n zs"
  assumes "max_Var_floatariths ea ≤ n"
  shows "interpret_floatariths ea ys = interpret_floatariths ea zs"
  by (rule interpret_floatariths_eq_take_max_VarI) (rule take_greater_eqI[OF assms])

lemma
  interpret_floatarith_fresh_eqI:
  assumes "⋀i. fresh_floatarith ea i ∨ (i < length ys ∧ i < length zs ∧ ys ! i = zs ! i)"
  shows "interpret_floatarith ea ys = interpret_floatarith ea zs"
  using assms
  by (induction ea) force+

lemma
  interpret_floatariths_fresh_eqI:
  assumes "⋀i. fresh_floatariths ea i ∨ (i < length ys ∧ i < length zs ∧ ys ! i = zs ! i)"
  shows "interpret_floatariths ea ys = interpret_floatariths ea zs"
  using assms
  apply (induction ea)
  subgoal by (force simp: interpret_floatarith_fresh_eqI intro: interpret_floatarith_fresh_eqI)
  subgoal for e ea
    apply clarsimp
    apply (auto simp: list_eq_iff_nth_eq)
    using interpret_floatarith_fresh_eqI by blast
  done

lemma
  interpret_floatarith_max_Var_cong:
  assumes "⋀i. i < max_Var_floatarith f ⟹ xs ! i = ys ! i"
  shows "interpret_floatarith f ys = interpret_floatarith f xs"
  using assms
  by (induction f) auto

lemma
  interpret_floatarith_fresh_cong:
  assumes "⋀i. ¬fresh_floatarith f i ⟹ xs ! i = ys ! i"
  shows "interpret_floatarith f ys = interpret_floatarith f xs"
  using assms
  by (induction f) auto

lemma max_Var_floatarith_le_max_Var_floatariths:
  "fa ∈ set fas ⟹ max_Var_floatarith fa ≤ max_Var_floatariths fas"
  by (induction fas) (auto simp: nth_Cons max_def split: nat.splits)

lemma max_Var_floatarith_le_max_Var_floatariths_nth:
  "n < length fas ⟹ max_Var_floatarith (fas ! n) ≤ max_Var_floatariths fas"
  by (rule max_Var_floatarith_le_max_Var_floatariths) auto

lemma max_Var_floatariths_leI:
  assumes "⋀i. i < length xs ⟹ max_Var_floatarith (xs ! i) ≤ F"
  shows "max_Var_floatariths xs ≤ F"
  using assms
  by (auto simp: max_Var_floatariths_Max in_set_conv_nth)

lemma fresh_floatariths_map_Var[simp]:
  "fresh_floatariths (map floatarith.Var xs) i ⟷ i ∉ set xs"
  by (induction xs) auto


lemma max_Var_floatarith_fold_const_fa:
  "max_Var_floatarith (fold_const_fa fa) ≤ max_Var_floatarith fa"
  by (induction fa) (auto simp: fold_const_fa.simps split!: option.splits floatarith.splits)

lemma max_Var_floatariths_fold_const_fa:
  "max_Var_floatariths (map fold_const_fa xs) ≤ max_Var_floatariths xs"
  by (auto simp: intro!: max_Var_floatariths_leI max_Var_floatarith_le_max_Var_floatariths_nth
      max_Var_floatarith_fold_const_fa[THEN order_trans])

lemma interpret_form_max_Var_cong:
  assumes "⋀i. i < max_Var_form f ⟹ xs ! i = ys ! i"
  shows "interpret_form f xs = interpret_form f ys"
  using assms
  by (induction f) (auto simp: interpret_floatarith_max_Var_cong[where xs=xs and ys=ys])

lemma max_Var_floatariths_lessI: "i < max_Var_floatarith (fas ! j) ⟹ j < length fas ⟹ i < max_Var_floatariths fas"
  by (metis leD le_trans less_le max_Var_floatarith_le_max_Var_floatariths nth_mem)

lemma interpret_floatariths_max_Var_cong:
  assumes "⋀i. i < max_Var_floatariths f ⟹ xs ! i = ys ! i"
  shows "interpret_floatariths f ys = interpret_floatariths f xs"
  by (auto intro!: nth_equalityI interpret_floatarith_max_Var_cong assms max_Var_floatariths_lessI)


lemma max_Var_floatarithimage_Var[simp]: "max_Var_floatarith ` Var ` X = Suc ` X" by force

lemma max_Var_floatariths_map_Var[simp]:
  "max_Var_floatariths (map Var xs) = (if xs = [] then 0 else Suc (linorder_class.Max (set xs)))"
  by (auto simp: max_Var_floatariths_Max hom_Max_commute split: if_splits)

lemma Max_atLeastLessThan_nat[simp]: "a < b ⟹ linorder_class.Max {a..<b} = b - 1" for a b::nat
  by (auto intro!: Max_eqI)


subsection ‹Derivatives›

lemma isDERIV_Power_iff: "isDERIV j (Power fa n) xs = (if n = 0 then True else isDERIV j fa xs)"
  by (cases n) auto

lemma isDERIV_max_Var_floatarithI:
  assumes "isDERIV n f ys"
  assumes "⋀i. i < max_Var_floatarith f ⟹ xs ! i = ys ! i"
  shows "isDERIV n f xs"
  using assms
proof (induction f)
  case (Power f n) then show ?case by (cases n) auto
qed (auto simp: max_def interpret_floatarith_max_Var_cong[of _ xs ys] split: if_splits)

definition isFDERIV where "isFDERIV n xs fas vs ⟷
  (∀i<n. ∀j<n. isDERIV (xs ! i) (fas ! j) vs) ∧ length fas = n ∧ length xs = n"

lemma isFDERIV_I: "(⋀i j. i < n ⟹ j < n ⟹ isDERIV (xs ! i) (fas ! j) vs) ⟹
  length fas = n ⟹ length xs = n ⟹ isFDERIV n xs fas vs"
  by (auto simp: isFDERIV_def)

lemma isFDERIV_isDERIV_D: "isFDERIV n xs fas vs ⟹ i < n ⟹ j < n ⟹ isDERIV (xs ! i) (fas ! j) vs"
  by (auto simp: isFDERIV_def)

lemma isFDERIV_lengthD: "length fas = n" "length xs = n" if "isFDERIV n xs fas vs"
  using that by (auto simp: isFDERIV_def)

lemma isFDERIV_uptD: "isFDERIV n [0..<n] fas vs ⟹ i < n ⟹ j < n ⟹ isDERIV i (fas ! j) vs"
  by (auto simp: isFDERIV_def)

lemma isFDERIV_max_Var_congI: "isFDERIV n xs fas ws"
  if f: "isFDERIV n xs fas vs" and c: "(⋀i. i < max_Var_floatariths fas ⟹ vs ! i = ws ! i)"
  using c f
  by (auto simp: isFDERIV_def max_Var_floatariths_lessI
      intro!: isFDERIV_I isDERIV_max_Var_floatarithI[OF isFDERIV_isDERIV_D[OF f]])

lemma isFDERIV_max_Var_cong: "isFDERIV n xs fas ws ⟷ isFDERIV n xs fas vs"
  if c: "(⋀i. i < max_Var_floatariths fas ⟹ vs ! i = ws ! i)"
  using c by (auto intro: isFDERIV_max_Var_congI)

lemma isDERIV_max_VarI:
  "i ≥ max_Var_floatarith fa ⟹ isDERIV j fa xs ⟹ isDERIV i fa xs"
  by (induction fa) (auto simp: isDERIV_Power_iff)

lemmas max_Var_floatarith_le_max_Var_floatariths_nthI =
  max_Var_floatarith_le_max_Var_floatariths_nth[THEN order_trans]


lemma
  isFDERIV_appendD1:
  assumes "isFDERIV (J + K) [0..<J + K] (es @ rs) xs"
  assumes "length es = J"
  assumes "length rs = K"
  assumes "max_Var_floatariths es ≤ J"
  shows "isFDERIV J [0..<J] (es) xs"
  unfolding isFDERIV_def
  apply (safe)
  subgoal for i j
    using assms
    apply (cases "i < length es")
    subgoal by (auto simp: nth_append isFDERIV_def) (metis add.commute trans_less_add2)
    subgoal
      apply (rule isDERIV_max_VarI[where j=0])
       apply (rule max_Var_floatarith_le_max_Var_floatariths_nthI)
         apply force
        apply force
       apply force
      done
    done
  subgoal by (auto simp: assms)
  subgoal by (auto simp: assms)
  done

lemma interpret_floatariths_Var[simp]:
  "interpret_floatariths (map floatarith.Var xs) vs = (map (nth vs) xs)"
  by (induction xs) (auto simp: )

lemma max_Var_floatariths_append[simp]: "max_Var_floatariths (xs @ ys) = max (max_Var_floatariths xs) (max_Var_floatariths ys)"
  by (induction xs) (auto)

lemma map_nth_append_upt[simp]:
  assumes "a ≥ length xs"
  shows "map ((!) (xs @ ys)) [a..<b] = map ((!) ys) [a - length xs..<b - length xs]"
  using assms
  by (auto intro!: nth_equalityI simp: nth_append)

lemma map_nth_Cons_upt[simp]:
  assumes "a > 0"
  shows "map ((!) (x # ys)) [a..<b] = map ((!) ys) [a - Suc 0..<b - Suc 0]"
  using assms
  by (auto intro!: nth_equalityI simp: nth_append)

lemma map_nth_eq_self[simp]:
  shows "length fas = l ⟹ (map ((!) fas) [0..<l]) = fas"
  by (auto simp: intro!: nth_equalityI)


lemma
  isFDERIV_appendI1:
  assumes "isFDERIV J [0..<J] (es) xs"
  assumes "⋀i j. i < J + K ⟹ j < K ⟹ isDERIV i (rs ! j) xs"
  assumes "length es = J"
  assumes "length rs = K"
  assumes "max_Var_floatariths es ≤ J"
  shows "isFDERIV (J + K) [0..<J + K] (es @ rs) xs"
  unfolding isFDERIV_def
  apply safe
  subgoal for i j
    using assms
    apply (cases "j < length es")
    subgoal
      apply (auto simp: nth_append isFDERIV_def)
      by (metis (no_types, hide_lams) isDERIV_max_VarI le_trans less_le
          max_Var_floatarith_le_max_Var_floatariths_nthI nat_le_linear)
    subgoal by (auto simp: nth_append)
    done
  subgoal by (auto simp: assms)
  subgoal by (auto simp: assms)
  done


lemma matrix_matrix_mult_zero[simp]:
  "a ** 0 = 0" "0 ** a = 0"
  by (vector matrix_matrix_mult_def)+

lemma scaleR_blinfun_compose_left: "i *⇩_R (A o⇩_L B) = i *⇩_R A o⇩_L B"
  and scaleR_blinfun_compose_right: "i *⇩_R (A o⇩_L B) = A o⇩_L i *⇩_R B"
  by (auto intro!: blinfun_eqI simp: blinfun.bilinear_simps)

lemma
  matrix_blinfun_compose:
  fixes A B::"(real ^ 'n) ⇒⇩_L (real ^ 'n)"
  shows "matrix (A o⇩_L B) = (matrix A) ** (matrix B)"
  by transfer (auto simp: matrix_compose linear_linear)

lemma matrix_add_rdistrib: "((B + C) ** A) = (B ** A) + (C ** A)"
  by (vector matrix_matrix_mult_def sum.distrib[symmetric] field_simps)

lemma matrix_scaleR_right: "r *⇩_R (a::'a::real_algebra_1^'n^'m) ** b = r *⇩_R (a ** b)"
  by (vector matrix_matrix_mult_def algebra_simps scaleR_sum_right)

lemma matrix_scaleR_left: "(a::'a::real_algebra_1^'n^'m) ** r *⇩_R b = r *⇩_R (a ** b)"
  by (vector matrix_matrix_mult_def algebra_simps scaleR_sum_right)

lemma bounded_bilinear_matrix_matrix_mult[bounded_bilinear]:
   "bounded_bilinear ((**)::
    ('a::{euclidean_space, real_normed_algebra_1}^'n^'m) ⇒
    ('a::{euclidean_space, real_normed_algebra_1}^'p^'n) ⇒
    ('a::{euclidean_space, real_normed_algebra_1}^'p^'m))"
  unfolding bilinear_conv_bounded_bilinear[symmetric]
  unfolding bilinear_def
  apply safe
  by unfold_locales (auto simp: matrix_add_ldistrib matrix_add_rdistrib matrix_scaleR_right matrix_scaleR_left)

lemma norm_axis: "norm (axis ia 1::'a::{real_normed_algebra_1}^'n) = 1"
  by (auto simp: axis_def norm_vec_def L2_set_def if_distrib if_distribR sum.delta
      cong: if_cong)

lemma abs_vec_nth_blinfun_apply_lemma:
  fixes x::"(real^'n) ⇒⇩_L (real^'m)"
  shows "abs (vec_nth (blinfun_apply x (axis ia 1)) i) ≤ norm x"
  apply (rule component_le_norm_cart[THEN order_trans])
  apply (rule norm_blinfun[THEN order_trans])
  by (auto simp: norm_axis)

lemma bounded_linear_matrix_blinfun_apply: "bounded_linear (λx::(real^'n) ⇒⇩_L (real^'m). matrix (blinfun_apply x))"
  apply standard
  subgoal by (vector blinfun.bilinear_simps matrix_def)
  subgoal by (vector blinfun.bilinear_simps matrix_def)
  apply (rule exI[where x="real (CARD('n) * CARD('m))"])
  apply (auto simp: matrix_def)
  apply (subst norm_vec_def)
  apply (rule L2_set_le_sum[THEN order_trans])
  apply simp
  apply auto
  apply (rule sum_mono[THEN order_trans])
  apply (subst norm_vec_def)
   apply (rule L2_set_le_sum)
   apply simp
  apply (rule sum_mono[THEN order_trans])
   apply (rule sum_mono)
    apply simp
    apply (rule abs_vec_nth_blinfun_apply_lemma)
  apply (simp add: abs_vec_nth_blinfun_apply_lemma)
  done

lemma matrix_has_derivative:
  shows "((λx::(real^'n)⇒⇩_L(real^'n). matrix (blinfun_apply x)) has_derivative (λh. matrix (blinfun_apply h))) (at x)"
  apply (auto simp: has_derivative_at2)
  unfolding linear_linear
  subgoal by (rule bounded_linear_matrix_blinfun_apply)
  subgoal
    by (auto simp: blinfun.bilinear_simps matrix_def) vector
  done

lemma
  matrix_comp_has_derivative[derivative_intros]:
  fixes f::"'a::real_normed_vector ⇒ ((real^'n)⇒⇩_L(real^'n))"
  assumes "(f has_derivative f') (at x within S)"
  shows "((λx. matrix (blinfun_apply (f x))) has_derivative (λx. matrix (f' x))) (at x within S)"
  using has_derivative_compose[OF assms matrix_has_derivative]
  by auto

fun inner_floatariths where
  "inner_floatariths [] _ = Num 0"
| "inner_floatariths _ [] = Num 0"
| "inner_floatariths (x#xs) (y#ys) = Add (Mult x y) (inner_floatariths xs ys)"

lemma interpret_floatarith_inner_eq:
  assumes "length xs = length ys"
  shows "interpret_floatarith (inner_floatariths xs ys) vs =
    (∑i<length ys. (interpret_floatariths xs vs ! i) * (interpret_floatariths ys vs ! i))"
  using assms
proof (induction rule: list_induct2)
  case Nil
  then show ?case by simp
next
  case (Cons x xs y ys)
  then show ?case
    unfolding length_Cons sum.lessThan_Suc_shift
    by simp
qed

lemma
  interpret_floatarith_inner_floatariths:
  assumes "length xs = DIM('a::executable_euclidean_space)"
  assumes "length ys = DIM('a)"
  assumes "eucl_of_list (interpret_floatariths xs vs) = (x::'a)"
  assumes "eucl_of_list (interpret_floatariths ys vs) = y"
  shows "interpret_floatarith (inner_floatariths xs ys) vs = x ∙ y"
  using assms
  by (subst euclidean_inner)
    (auto simp: interpret_floatarith_inner_eq sum_Basis_sum_nth_Basis_list eucl_of_list_inner
      index_nth_id
      intro!: euclidean_eqI[where 'a='a] sum.cong)

lemma max_Var_floatarith_inner_floatariths[simp]:
  assumes "length f = length g"
  shows "max_Var_floatarith (inner_floatariths f g) = max (max_Var_floatariths f) (max_Var_floatariths g)"
  using assms
  by (induction f g rule: list_induct2) auto


definition FDERIV_floatarith where
  "FDERIV_floatarith fa xs d = inner_floatariths (map (λx. fold_const_fa (DERIV_floatarith x fa)) xs) d"
― ‹TODO: specialize to ‹FDERIV_floatarith fa [0..<n] [m..<m + n]› and do the rest with @{term subst_floatarith}?
   TODO: introduce approximation on type @{typ "real^'i^'j"} and use @{term jacobian}?›

lemma interpret_floatariths_map: "interpret_floatariths (map f xs) vs = map (λx. interpret_floatarith (f x) vs) xs"
  by (induct xs) (auto simp: )

lemma max_Var_floatarith_DERIV_floatarith:
  "max_Var_floatarith (DERIV_floatarith x fa) ≤ max_Var_floatarith fa"
  by (induction x fa rule: DERIV_floatarith.induct) (auto)

lemma max_Var_floatarith_FDERIV_floatarith:
  "length xs = length d ⟹
    max_Var_floatarith (FDERIV_floatarith fa xs d) ≤ max (max_Var_floatarith fa) (max_Var_floatariths d)"
  unfolding FDERIV_floatarith_def
  by (auto simp: max_Var_floatariths_Max intro!: max_Var_floatarith_DERIV_floatarith[THEN order_trans]
      max_Var_floatarith_fold_const_fa[THEN order_trans])

definition FDERIV_floatariths where
  "FDERIV_floatariths fas xs d = map (λfa. FDERIV_floatarith fa xs d) fas"

lemma max_Var_floatarith_FDERIV_floatariths:
  "length xs = length d ⟹ max_Var_floatariths (FDERIV_floatariths fa xs d) ≤ max (max_Var_floatariths fa) (max_Var_floatariths d)"
  by (auto simp: FDERIV_floatariths_def max_Var_floatariths_Max
      intro!: max_Var_floatarith_FDERIV_floatarith[THEN order_trans])
    (auto simp: max_def)

lemma length_FDERIV_floatariths[simp]:
  "length (FDERIV_floatariths fas xs ds) = length fas"
  by (auto simp: FDERIV_floatariths_def)

lemma FDERIV_floatariths_nth[simp]:
  "i < length fas ⟹ FDERIV_floatariths fas xs ds ! i  = FDERIV_floatarith (fas ! i) xs ds"
  by (auto simp: FDERIV_floatariths_def)

definition "FDERIV_n_floatariths fas xs ds n = ((λx. FDERIV_floatariths x xs ds)^^n) fas"

lemma FDERIV_n_floatariths_Suc[simp]:
  "FDERIV_n_floatariths fa xs ds 0 = fa"
  "FDERIV_n_floatariths fa xs ds (Suc n) = FDERIV_floatariths (FDERIV_n_floatariths fa xs ds n) xs ds"
  by (auto simp: FDERIV_n_floatariths_def)

lemma length_FDERIV_n_floatariths[simp]: "length (FDERIV_n_floatariths fa xs ds n) = length fa"
  by (induction n) (auto simp: FDERIV_n_floatariths_def)

lemma max_Var_floatarith_FDERIV_n_floatariths:
  "length xs = length d ⟹ max_Var_floatariths (FDERIV_n_floatariths fa xs d n) ≤ max (max_Var_floatariths fa) (max_Var_floatariths d)"
  by (induction n)
    (auto intro!: max_Var_floatarith_FDERIV_floatariths[THEN order_trans] simp: FDERIV_n_floatariths_def)

lemma interpret_floatarith_FDERIV_floatarith_cong:
  assumes rq: "⋀i. i < max_Var_floatarith f ⟹ rs ! i = qs ! i"
  assumes [simp]: "length ds = length xs" "length es = length xs"
  assumes "interpret_floatariths ds qs = interpret_floatariths es rs"
  shows "interpret_floatarith (FDERIV_floatarith f xs ds) qs =
   interpret_floatarith (FDERIV_floatarith f xs es) rs"
  apply (auto simp: FDERIV_floatarith_def interpret_floatarith_inner_eq)
  apply (rule sum.cong[OF refl])
  subgoal premises prems for i
  proof -
    have "interpret_floatarith (DERIV_floatarith (xs ! i) f) qs = interpret_floatarith (DERIV_floatarith (xs ! i) f) rs"
      apply (rule interpret_floatarith_max_Var_cong)
      apply (auto simp: intro!: rq)
      by (metis leD le_trans max_Var_floatarith_DERIV_floatarith nat_less_le)
    moreover
    have "interpret_floatarith (ds ! i) qs = interpret_floatarith (es ! i) rs"
      using assms
      by (metis ‹i ∈ {..<length xs}› interpret_floatariths_nth lessThan_iff)
    ultimately show ?thesis by auto
  qed
  done

theorem
  matrix_vector_mult_eq_list_of_eucl_nth:
  "(M::real^'n::enum^'m::enum) *v v =
    (∑i<CARD('m).
      (∑j<CARD('n). list_of_eucl M ! (i * CARD('n) + j) * list_of_eucl v ! j) *⇩_R Basis_list ! i)"
  using eucl_of_list_matrix_vector_mult_eq_sum_nth_Basis_list[of "list_of_eucl M" "list_of_eucl v",
      where 'n='n and 'm = 'm]
  by auto

definition "mmult_fa l m n AS BS =
  concat (map (λi. map (λk. inner_floatariths
    (map (λj. AS ! (i * m + j)) [0..<m]) (map (λj. BS ! (j * n + k)) [0..<m])) [0..<n]) [0..<l])"

lemma length_mmult_fa[simp]: "length (mmult_fa l m n AS BS) = l * n"
  by (auto simp: mmult_fa_def length_concat o_def sum_list_distinct_conv_sum_set)

lemma einterpret_mmult_fa:
  assumes [simp]: "Dn = CARD('n::enum)" "Dm = CARD('m::enum)" "Dl = CARD('l::enum)"
    "length A = CARD('l)*CARD('m)" "length B = CARD('m)*CARD('n)"
  shows "einterpret (mmult_fa Dl Dm Dn A B) vs = (einterpret A vs::((real, 'm::enum) vec, 'l) vec) ** (einterpret B vs::((real, 'n::enum) vec, 'm) vec)"
  apply (vector matrix_matrix_mult_def)
  apply (auto simp: mmult_fa_def vec_nth_eucl_of_list_eq2 index_Basis_list_axis2
      concat_map_map_index length_concat o_def sum_list_distinct_conv_sum_set
      interpret_floatarith_inner_eq)
  apply (subst sum_index_enum_eq)
  apply simp
  done

lemma max_Var_floatariths_mmult_fa:
  assumes [simp]: "length A = D * E" "length B = E * F"
  shows "max_Var_floatariths (mmult_fa D E F A B) ≤ max (max_Var_floatariths A) (max_Var_floatariths B)"
  apply (auto simp: mmult_fa_def concat_map_map_index intro!: max_Var_floatariths_leI)
   apply (rule max.coboundedI1)
   apply (auto intro!: max_Var_floatarith_le_max_Var_floatariths_nth max.coboundedI2)
  apply (cases "F = 0")
   apply simp_all
  done

lemma isDERIV_inner_iff:
  assumes "length xs = length ys"
  shows "isDERIV i (inner_floatariths xs ys) vs ⟷
    (∀k < length xs. isDERIV i (xs ! k) vs) ∧ (∀k < length ys. isDERIV i (ys ! k) vs)"
  using assms
  by (induction xs ys rule: list_induct2) (auto simp: nth_Cons split: nat.splits)

lemma isDERIV_Power: "isDERIV x (fa) vs ⟹ isDERIV x (fa ^⇩_e n) vs"
  by (induction n) (auto simp: FDERIV_floatarith_def isDERIV_inner_iff)

lemma isDERIV_mmult_fa_nth:
  assumes "⋀j. j < D * E ⟹ isDERIV i (A ! j) xs"
  assumes "⋀j. j < E * F ⟹ isDERIV i (B ! j) xs"
  assumes [simp]: "length A = D * E" "length B = E * F" "j < D * F"
  shows "isDERIV i (mmult_fa D E F A B ! j) xs"
  using assms
  apply (cases "F = 0")
  apply (auto simp: mmult_fa_def concat_map_map_index isDERIV_inner_iff ac_simps)
  apply (metis add.commute assms(5) in_square_lemma less_square_imp_div_less mult.commute)
  done

definition "mvmult_fa n m AS B =
  map (λi. inner_floatariths (map (λj. AS ! (i * m + j)) [0..<m]) (map (λj. B ! j) [0..<m])) [0..<n]"

lemma einterpret_mvmult_fa:
  assumes [simp]: "Dn = CARD('n::enum)" "Dm = CARD('m::enum)"
    "length A = CARD('n)*CARD('m)" "length B = CARD('m)"
  shows "einterpret (mvmult_fa Dn Dm A B) vs = (einterpret A vs::((real, 'm::enum) vec, 'n) vec) *v (einterpret B vs::(real, 'm) vec)"
  apply (vector matrix_vector_mult_def)
  apply (auto simp: mvmult_fa_def vec_nth_eucl_of_list_eq2 index_Basis_list_axis2 index_Basis_list_axis1 vec_nth_eucl_of_list_eq
      concat_map_map_index length_concat o_def sum_list_distinct_conv_sum_set
      interpret_floatarith_inner_eq)
  apply (subst sum_index_enum_eq)
  apply simp
  done


lemma max_Var_floatariths_mvult_fa:
  assumes [simp]: "length A = D * E" "length B = E"
  shows "max_Var_floatariths (mvmult_fa D E A B) ≤ max (max_Var_floatariths A) (max_Var_floatariths B)"
  apply (auto simp: mvmult_fa_def concat_map_map_index intro!: max_Var_floatariths_leI)
   apply (rule max.coboundedI1)
  by (auto intro!: max_Var_floatarith_le_max_Var_floatariths_nth max.coboundedI2)

lemma isDERIV_mvmult_fa_nth:
  assumes "⋀j. j < D * E ⟹ isDERIV i (A ! j) xs"
  assumes "⋀j. j < E ⟹ isDERIV i (B ! j) xs"
  assumes [simp]: "length A = D * E" "length B = E" "j < D"
  shows "isDERIV i (mvmult_fa D E A B ! j) xs"
  using assms
  apply (auto simp: mvmult_fa_def concat_map_map_index isDERIV_inner_iff ac_simps)
  by (metis assms(5) in_square_lemma semiring_normalization_rules(24) semiring_normalization_rules(7))

lemma max_Var_floatariths_mapI:
  assumes "⋀x. x ∈ set xs ⟹ max_Var_floatarith (f x) ≤ m"
  shows "max_Var_floatariths (map f xs) ≤ m"
  using assms
  by (force intro!: max_Var_floatariths_leI simp: in_set_conv_nth)

lemma
  max_Var_floatariths_list_updateI:
  assumes "max_Var_floatariths xs ≤ m"
  assumes "max_Var_floatarith v ≤ m"
  assumes "i < length xs"
  shows "max_Var_floatariths (xs[i := v]) ≤ m"
  using assms
  apply (auto simp: nth_list_update intro!: max_Var_floatariths_leI )
  using max_Var_floatarith_le_max_Var_floatariths_nthI by blast

lemma
  max_Var_floatariths_replicateI:
  assumes "max_Var_floatarith v ≤ m"
  shows "max_Var_floatariths (replicate n v) ≤ m"
  using assms
  by (auto intro!: max_Var_floatariths_leI )

definition "FDERIV_n_floatarith fa xs ds n = ((λx. FDERIV_floatarith x xs ds)^^n) fa"
lemma FDERIV_n_floatariths_nth: "i < length fas ⟹ FDERIV_n_floatariths fas xs ds n ! i = FDERIV_n_floatarith (fas ! i) xs ds n"
  by (induction n)
    (auto simp: FDERIV_n_floatarith_def FDERIV_floatariths_nth)


lemma einterpret_fold_const_fa[simp]:
  "(einterpret (map (λi. fold_const_fa (fa i)) xs) vs::'a::executable_euclidean_space) =
    einterpret (map fa xs) vs" if "length xs = DIM('a)"
  using that
  by (auto intro!: euclidean_eqI[where 'a='a] simp: algebra_simps eucl_of_list_inner)

lemma einterpret_plus[simp]:
  shows "(einterpret (map (λi. fa1 i + fa2 i) [0..<DIM('a)]) vs::'a) =
    einterpret (map fa1 [0..<DIM('a::executable_euclidean_space)]) vs + einterpret (map fa2 [0..<DIM('a)]) vs"
  by (auto intro!: euclidean_eqI[where 'a='a] simp: algebra_simps eucl_of_list_inner)

lemma einterpret_uminus[simp]:
  shows "(einterpret (map (λi. - fa1 i) [0..<DIM('a)]) vs::'a::executable_euclidean_space) =
    - einterpret (map fa1 [0..<DIM('a)]) vs"
  by (auto intro!: euclidean_eqI[where 'a='a] simp: algebra_simps eucl_of_list_inner)

lemma diff_floatarith_conv_add_uminus: "a - b = a + - b" for a b::floatarith
  by (auto simp: minus_floatarith_def plus_floatarith_def uminus_floatarith_def)

lemma einterpret_minus[simp]:
  shows "(einterpret (map (λi. fa1 i - fa2 i) [0..<DIM('a)]) vs::'a::executable_euclidean_space) =
    einterpret (map fa1 [0..<DIM('a)]) vs - einterpret (map fa2 [0..<DIM('a)]) vs"
  by (simp add: diff_floatarith_conv_add_uminus)

lemma einterpret_scaleR[simp]:
  shows "(einterpret (map (λi. fa1 * fa2 i) [0..<DIM('a)]) vs::'a::executable_euclidean_space) =
    interpret_floatarith (fa1) vs *⇩_R einterpret (map fa2 [0..<DIM('a)]) vs"
  by (auto intro!: euclidean_eqI[where 'a='a] simp: algebra_simps eucl_of_list_inner)

lemma einterpret_nth[simp]:
  assumes [simp]: "length xs = DIM('a)"
  shows "(einterpret (map ((!) xs) [0..<DIM('a)]) vs::'a::executable_euclidean_space) = einterpret xs vs"
  by (auto intro!: euclidean_eqI[where 'a='a] simp: algebra_simps eucl_of_list_inner)

type_synonym 'n rvec = "(real, 'n) vec"

lemma length_mvmult_fa[simp]: "length (mvmult_fa D E xs ys) = D"
  by (auto simp: mvmult_fa_def)

lemma interpret_mvmult_nth:
  assumes "D = CARD('n::enum)"
  assumes "E = CARD('m::enum)"
  assumes "length xs = D * E"
  assumes "length ys = E"
  assumes "n < CARD('n)"
  shows "interpret_floatarith (mvmult_fa D E xs ys ! n) vs =
    ((einterpret xs vs::((real, 'm) vec, 'n) vec) *v einterpret ys vs) ∙ (Basis_list ! n)"
proof -
  have "interpret_floatarith (mvmult_fa D E xs ys ! n) vs = einterpret (mvmult_fa D E xs ys) vs ∙ (Basis_list ! n::'n rvec)"
    using assms
    by (auto simp: eucl_of_list_inner)
  also
  from einterpret_mvmult_fa[OF assms(1,2), of xs ys vs]
  have "einterpret (mvmult_fa D E xs ys) vs = (einterpret xs vs::((real, 'm) vec, 'n) vec) *v einterpret ys vs"
    using assms by simp
  finally show ?thesis by simp
qed


lemmas [simp del] = fold_const_fa.simps

lemma take_eq_map_nth: "n < length xs ⟹ take n xs = map ((!) xs) [0..<n]"
  by (induction xs) (auto intro!: nth_equalityI)

lemmas [simp del] = upt_rec_numeral
lemmas map_nth_eq_take = take_eq_map_nth[symmetric]


subsection ‹Definition of Approximating Function using Affine Arithmetic›

lemma interpret_Floatreal: "interpret_floatarith (floatarith.Num f) vs = (real_of_float f)"
  by simp

ML ‹
(* Make a congruence rule out of a defining equation for the interpretation

   th is one defining equation of f,
     i.e. th is "f (Cp ?t1 ... ?tn) = P(f ?t1, .., f ?tn)" 
   Cp is a constructor pattern and P is a pattern 

   The result is:
     [|?A1 = f ?t1 ; .. ; ?An= f ?tn |] ==> P (?A1, .., ?An) = f (Cp ?t1 .. ?tn)
       + the a list of names of the A1 .. An, Those are fresh in the ctxt *)

fun mk_congeq ctxt fs th =
  let
    val Const (fN, _) = th |> Thm.prop_of |> HOLogic.dest_Trueprop |> HOLogic.dest_eq
      |> fst |> strip_comb |> fst;
    val ((_, [th']), ctxt') = Variable.import true [th] ctxt;
    val (lhs, rhs) = HOLogic.dest_eq (HOLogic.dest_Trueprop (Thm.prop_of th'));
    fun add_fterms (t as t1 $ t2) =
          if exists (fn f => Term.could_unify (t |> strip_comb |> fst, f)) fs
          then insert (op aconv) t
          else add_fterms t1 #> add_fterms t2
      | add_fterms (t as Abs _) =
          if exists_Const (fn (c, _) => c = fN) t
          then K [t]
          else K []
      | add_fterms _ = I;
    val fterms = add_fterms rhs [];
    val (xs, ctxt'') = Variable.variant_fixes (replicate (length fterms) "x") ctxt';
    val tys = map fastype_of fterms;
    val vs = map Free (xs ~~ tys);
    val env = fterms ~~ vs; (*FIXME*)
    fun replace_fterms (t as t1 $ t2) =
        (case AList.lookup (op aconv) env t of
            SOME v => v
          | NONE => replace_fterms t1 $ replace_fterms t2)
      | replace_fterms t =
        (case AList.lookup (op aconv) env t of
            SOME v => v
          | NONE => t);
    fun mk_def (Abs (x, xT, t), v) =
          HOLogic.mk_Trueprop (HOLogic.all_const xT $ Abs (x, xT, HOLogic.mk_eq (v $ Bound 0, t)))
      | mk_def (t, v) = HOLogic.mk_Trueprop (HOLogic.mk_eq (v, t));
    fun tryext x =
      (x RS @{lemma "(∀x. f x = g x) ⟹ f = g" by blast} handle THM _ => x);
    val cong =
      (Goal.prove ctxt'' [] (map mk_def env)
        (HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs, replace_fterms rhs)))
        (fn {context, prems, ...} =>
          Local_Defs.unfold0_tac context (map tryext prems) THEN resolve_tac ctxt'' [th'] 1)) RS sym;
    val (cong' :: vars') =
      Variable.export ctxt'' ctxt (cong :: map (Drule.mk_term o Thm.cterm_of ctxt'') vs);
    val vs' = map (fst o fst o Term.dest_Var o Thm.term_of o Drule.dest_term) vars';

  in (vs', cong') end;

fun mk_congs ctxt eqs =
  let
    val fs = fold_rev (fn eq => insert (op =) (eq |> Thm.prop_of |> HOLogic.dest_Trueprop
      |> HOLogic.dest_eq |> fst |> strip_comb
      |> fst)) eqs [];
    val tys = fold_rev (fn f => fold (insert (op =)) (f |> fastype_of |> binder_types |> tl)) fs [];
    val (vs, ctxt') = Variable.variant_fixes (replicate (length tys) "vs") ctxt;
    val subst =
      the o AList.lookup (op =)
        (map2 (fn T => fn v => (T, Thm.cterm_of ctxt' (Free (v, T)))) tys vs);
    fun prep_eq eq =
      let
        val (_, _ :: vs) = eq |> Thm.prop_of |> HOLogic.dest_Trueprop
          |> HOLogic.dest_eq |> fst |> strip_comb;
        val subst = map_filter (fn Var v => SOME (v, subst (#2 v)) | _ => NONE) vs;
      in Thm.instantiate ([], subst) eq end;
    val (ps, congs) = map_split (mk_congeq ctxt' fs o prep_eq) eqs;
    val bds = AList.make (K ([], [])) tys;
  in (ps ~~ Variable.export ctxt' ctxt congs, bds) end
›

ML ‹
fun interpret_floatariths_congs ctxt =
  mk_congs ctxt @{thms interpret_floatarith.simps interpret_floatariths.simps}
  |> fst
  |> map snd
›

ML ‹
fun preproc_form_conv ctxt =
  Simplifier.rewrite
   (put_simpset HOL_basic_ss ctxt addsimps
     (Named_Theorems.get ctxt @{named_theorems approximation_preproc}))›

ML ‹fun reify_floatariths_tac ctxt i =
  CONVERSION (preproc_form_conv ctxt) i
  THEN REPEAT_ALL_NEW (fn i => resolve_tac ctxt (interpret_floatariths_congs ctxt) i) i›

method_setup reify_floatariths = ‹
  Scan.succeed (fn ctxt => SIMPLE_METHOD' (reify_floatariths_tac ctxt))
› "reification of floatariths expression"

schematic_goal reify_example:
  "[xs!i * xs!j, xs!i + xs!j powr (sin (xs!0)), xs!k + (2 / 3 * xs!i * xs!j)] = interpret_floatariths ?fas xs"
  by (reify_floatariths)

ML ‹fun interpret_floatariths_step_tac ctxt i = resolve_tac ctxt (interpret_floatariths_congs ctxt) i›

method_setup reify_floatariths_step = ‹
  Scan.succeed (fn ctxt => SIMPLE_METHOD' (interpret_floatariths_step_tac ctxt))
› "reification of floatariths expression (step)"

lemma eucl_of_list_interpret_floatariths_cong:
  fixes y::"'a::executable_euclidean_space"
  assumes "⋀b. b ∈ Basis ⟹ interpret_floatarith (fa (index Basis_list b)) vs = y ∙ b"
  assumes "length xs = DIM('a)"
  shows "eucl_of_list (interpret_floatariths (map fa [0..<DIM('a)]) vs) = y"
  apply (rule euclidean_eqI)
  apply (subst eucl_of_list_inner)
  by (auto simp: assms)

lemma interpret_floatariths_fold_const_fa[simp]:
  "interpret_floatariths (map fold_const_fa ds) = interpret_floatariths ds"
  by (auto intro!: nth_equalityI)

fun subst_floatarith where
"subst_floatarith s (Add a b)         = Add (subst_floatarith s a) (subst_floatarith s b)" |
"subst_floatarith s (Mult a b)        = Mult (subst_floatarith s a) (subst_floatarith s b)" |
"subst_floatarith s (Minus a)         = Minus (subst_floatarith s a)" |
"subst_floatarith s (Inverse a)       = Inverse (subst_floatarith s a)" |
"subst_floatarith s (Cos a)           = Cos (subst_floatarith s a)" |
"subst_floatarith s (Arctan a)        = Arctan (subst_floatarith s a)" |
"subst_floatarith s (Min a b)         = Min (subst_floatarith s a) (subst_floatarith s b)" |
"subst_floatarith s (Max a b)         = Max (subst_floatarith s a) (subst_floatarith s b)" |
"subst_floatarith s (Abs a)           = Abs (subst_floatarith s a)" |
"subst_floatarith s Pi                = Pi" |
"subst_floatarith s (Sqrt a)          = Sqrt (subst_floatarith s a)" |
"subst_floatarith s (Exp a)           = Exp (subst_floatarith s a)" |
"subst_floatarith s (Powr a b)        = Powr (subst_floatarith s a) (subst_floatarith s b)" |
"subst_floatarith s (Ln a)            = Ln (subst_floatarith s a)" |
"subst_floatarith s (Power a i)       = Power (subst_floatarith s a) i" |
"subst_floatarith s (Floor a)         = Floor (subst_floatarith s a)" |
"subst_floatarith s (Num f)           = Num f" |
"subst_floatarith s (Var n)           = s n"

lemma interpret_floatarith_subst_floatarith:
  assumes "max_Var_floatarith fa ≤ D"
  shows "interpret_floatarith (subst_floatarith s fa) vs =
    interpret_floatarith fa (map (λi. interpret_floatarith (s i) vs) [0..<D])"
  using assms
  by (induction fa) auto

lemma max_Var_floatarith_subst_floatarith_le[THEN order_trans]:
  assumes "length xs ≥ max_Var_floatarith fa"
  shows "max_Var_floatarith (subst_floatarith ((!) xs) fa) ≤ max_Var_floatariths xs"
  using assms
  by (induction fa) (auto intro!: max_Var_floatarith_le_max_Var_floatariths_nth)

lemma max_Var_floatariths_subst_floatarith_le[THEN order_trans]:
  assumes "length xs ≥ max_Var_floatariths fas"
  shows "max_Var_floatariths (map (subst_floatarith ((!) xs)) fas) ≤ max_Var_floatariths xs"
  using assms
  by (induction fas) (auto simp: max_Var_floatarith_subst_floatarith_le)

fun continuous_on_floatarith :: "floatarith ⇒ bool" where
  "continuous_on_floatarith (Add a b)         = (continuous_on_floatarith a ∧ continuous_on_floatarith b)" |
"continuous_on_floatarith (Mult a b)        = (continuous_on_floatarith a ∧ continuous_on_floatarith b)" |
"continuous_on_floatarith (Minus a)         = continuous_on_floatarith a" |
"continuous_on_floatarith (Inverse a)       = False" |
"continuous_on_floatarith (Cos a)           = continuous_on_floatarith a" |
"continuous_on_floatarith (Arctan a)        = continuous_on_floatarith a" |
"continuous_on_floatarith (Min a b)         = (continuous_on_floatarith a ∧ continuous_on_floatarith b)" |
"continuous_on_floatarith (Max a b) = (continuous_on_floatarith a ∧ continuous_on_floatarith b)" |
"continuous_on_floatarith (Abs a)           = continuous_on_floatarith a" |
"continuous_on_floatarith Pi                = True" |
"continuous_on_floatarith (Sqrt a)          = False" |
"continuous_on_floatarith (Exp a)           = continuous_on_floatarith a" |
"continuous_on_floatarith (Powr a b)        = False" |
"continuous_on_floatarith (Ln a)            = False" |
"continuous_on_floatarith (Floor a)         = False" |
"continuous_on_floatarith (Power a n)       = (if n = 0 then True else continuous_on_floatarith a)" |
"continuous_on_floatarith (Num f)           = True" |
"continuous_on_floatarith (Var n)           = True"

definition "Maxs⇩_e xs = fold (λa b. floatarith.Max a b) xs"
definition "norm2⇩_e n = Maxs⇩_e (map (λj. Norm (map (λi. Var (Suc j * n + i)) [0..<n])) [0..<n]) (Num 0)"

definition "N⇩_r l = Num (float_of l)"

lemma interpret_floatarith_Norm:
  "interpret_floatarith (Norm xs) vs = L2_set (λi. interpret_floatarith (xs ! i) vs) {0..<length xs}"
  by (auto simp: Norm_def L2_set_def sum_list_sum_nth power2_eq_square)

lemma interpret_floatarith_Nr[simp]: "interpret_floatarith (N⇩_r U) vs = real_of_float (float_of U)"
  by (auto simp: N⇩_r_def)


fun list_updates where
  "list_updates [] _ xs = xs"
| "list_updates _ [] xs = xs"
| "list_updates (i#is) (u#us) xs = list_updates is us (xs[i:=u])"


lemma list_updates_nth_notmem:
  assumes "length xs = length ys"
  assumes "i ∉ set xs"
  shows "list_updates xs ys vs ! i = vs ! i"
  using assms
  by (induction xs ys arbitrary: i vs rule: list_induct2) auto

lemma list_updates_nth_less:
  assumes "length xs = length ys" "distinct xs"
  assumes "i < length vs"
  shows "list_updates xs ys vs ! i = (if i ∈ set xs then ys ! (index xs i) else vs ! i)"
  using assms
  by (induction xs ys arbitrary: i vs rule: list_induct2) (auto simp: list_updates_nth_notmem)

lemma length_list_updates[simp]: "length (list_updates xs ys vs) = length vs"
  by (induction xs ys vs rule: list_updates.induct) simp_all

lemma list_updates_nth_ge[simp]:
  "x ≥ length vs ⟹ length xs = length ys ⟹ list_updates xs ys vs ! x = vs ! x"
  apply (induction xs ys vs rule: list_updates.induct)
  apply (auto simp: nth_list_update)
  by (metis list_update_beyond nth_list_update_neq)

lemma
  list_updates_nth:
  assumes [simp]: "length xs = length ys" "distinct xs"
  shows "list_updates xs ys vs ! i = (if i < length vs ∧ i ∈ set xs then ys ! index xs i else vs ! i)" 
  by (auto simp: list_updates_nth_less list_updates_nth_notmem)

lemma list_of_eucl_coord_update:
  assumes [simp]: "length xs = DIM('a::executable_euclidean_space)"
  assumes [simp]: "distinct xs"
  assumes [simp]: "i ∈ Basis"
  assumes [simp]: "⋀n. n ∈ set xs ⟹ n < length vs"
  shows "list_updates xs (list_of_eucl (x + (p - x ∙ i) *⇩_R i::'a)) vs =
   (list_updates xs (list_of_eucl x) vs)[xs ! index Basis_list i := p]"
  apply (auto intro!: nth_equalityI simp: list_updates_nth nth_list_update)
   apply (simp add: algebra_simps inner_Basis index_nth_id)
  apply (auto simp add: algebra_simps inner_Basis index_nth_id)
  done

definition "eucl_of_env is vs = eucl_of_list (map (nth vs) is)"

lemma list_updates_list_of_eucl_of_env[simp]:
  assumes [simp]: "length xs = DIM('a::executable_euclidean_space)" "distinct xs"
  shows "list_updates xs (list_of_eucl (eucl_of_env xs vs::'a)) vs = vs"
  by (auto intro!: nth_equalityI simp: list_updates_nth nth_list_update eucl_of_env_def)

lemma nth_nth_eucl_of_env_inner:
  "b ∈ Basis ⟹ length is = DIM('a) ⟹ vs ! (is ! index Basis_list b) = eucl_of_env is vs ∙ b"
  for b::"'a::executable_euclidean_space"
  by (auto simp: eucl_of_env_def eucl_of_list_inner)

lemma list_updates_idem[simp]:
  assumes "(⋀i. i ∈ set X0 ⟹ i < length vs)"
  shows "(list_updates X0 (map ((!) vs) X0) vs) = vs"
  using assms
  by (induction X0) auto


lemma pairwise_orthogonal_Basis[intro, simp]: "pairwise orthogonal Basis"
  by (auto simp: pairwise_alt orthogonal_def inner_Basis)

primrec freshs_floatarith where
  "freshs_floatarith (Var y) x ⟷ (y ∉ set x)"
| "freshs_floatarith (Num a) x ⟷ True"
| "freshs_floatarith Pi x ⟷ True"
| "freshs_floatarith (Cos a) x ⟷ freshs_floatarith a x"
| "freshs_floatarith (Abs a) x ⟷ freshs_floatarith a x"
| "freshs_floatarith (Arctan a) x ⟷ freshs_floatarith a x"
| "freshs_floatarith (Sqrt a) x ⟷ freshs_floatarith a x"
| "freshs_floatarith (Exp a) x ⟷ freshs_floatarith a x"
| "freshs_floatarith (Floor a) x ⟷ freshs_floatarith a x"
| "freshs_floatarith (Power a n) x ⟷ freshs_floatarith a x"
| "freshs_floatarith (Minus a) x ⟷ freshs_floatarith a x"
| "freshs_floatarith (Ln a) x ⟷ freshs_floatarith a x"
| "freshs_floatarith (Inverse a) x ⟷ freshs_floatarith a x"
| "freshs_floatarith (Add a b) x ⟷ freshs_floatarith a x ∧ freshs_floatarith b x"
| "freshs_floatarith (Mult a b) x ⟷ freshs_floatarith a x ∧ freshs_floatarith b x"
| "freshs_floatarith (floatarith.Max a b) x ⟷ freshs_floatarith a x ∧ freshs_floatarith b x"
| "freshs_floatarith (floatarith.Min a b) x ⟷ freshs_floatarith a x ∧ freshs_floatarith b x"
| "freshs_floatarith (Powr a b) x ⟷ freshs_floatarith a x ∧ freshs_floatarith b x"

lemma freshs_floatarith[simp]:
  assumes "freshs_floatarith fa ds" "length ds = length xs"
  shows "interpret_floatarith fa (list_updates ds xs vs) = interpret_floatarith fa vs"
  using assms
  by (induction fa) (auto simp: list_updates_nth_notmem)

lemma freshs_floatarith_max_Var_floatarithI:
  assumes "⋀x. x ∈ set xs ⟹ max_Var_floatarith f ≤ x"
  shows "freshs_floatarith f xs"
  using assms Suc_n_not_le_n
  by (induction f; force)

definition "freshs_floatariths fas xs = (∀fa∈set fas. freshs_floatarith fa xs)"

lemma freshs_floatariths_max_Var_floatarithsI:
  assumes "⋀x. x ∈ set xs ⟹ max_Var_floatariths f ≤ x"
  shows "freshs_floatariths f xs"
  using assms le_trans max_Var_floatarith_le_max_Var_floatariths
  by (force simp: freshs_floatariths_def intro!: freshs_floatarith_max_Var_floatarithI)

lemma freshs_floatariths_freshs_floatarithI:
  assumes "⋀fa. fa ∈ set fas ⟹ freshs_floatarith fa xs"
  shows "freshs_floatariths fas xs"
  by (auto simp: freshs_floatariths_def assms)

lemma fresh_floatariths_fresh_floatarithI:
  assumes "freshs_floatariths fas xs"
  assumes "fa ∈ set fas"
  shows "freshs_floatarith fa xs"
  using assms
  by (auto simp: freshs_floatariths_def)

lemma fresh_floatariths_fresh_floatarith[simp]:
  "fresh_floatariths (fas) i ⟹ fa ∈ set fas ⟹ fresh_floatarith fa i"
  by (induction fas) auto

lemma interpret_floatariths_fresh_cong:
  assumes "⋀i. ¬fresh_floatariths f i ⟹ xs ! i = ys ! i"
  shows "interpret_floatariths f ys = interpret_floatariths f xs"
  by (auto intro!: nth_equalityI assms interpret_floatarith_fresh_cong simp: )

fun subterms :: "floatarith ⇒ floatarith set" where
"subterms (Add a b) = insert (Add a b) (subterms a ∪ subterms b)" |
"subterms (Mult a b) = insert (Mult a b) (subterms a ∪ subterms b)" |
"subterms (Min a b) = insert (Min a b) (subterms a ∪ subterms b)" |
"subterms (floatarith.Max a b) = insert (floatarith.Max a b) (subterms a ∪ subterms b)" |
"subterms (Powr a b) = insert (Powr a b) (subterms a ∪ subterms b)" |
"subterms (Inverse a) = insert (Inverse a) (subterms a)" |
"subterms (Cos a) = insert (Cos a) (subterms a)" |
"subterms (Arctan a) = insert (Arctan a) (subterms a)" |
"subterms (Abs a) = insert (Abs a) (subterms a)" |
"subterms (Sqrt a) = insert (Sqrt a) (subterms a)" |
"subterms (Exp a) = insert (Exp a) (subterms a)" |
"subterms (Ln a) = insert (Ln a) (subterms a)" |
"subterms (Power a n) = insert (Power a n) (subterms a)" |
"subterms (Floor a) = insert (Floor a) (subterms a)" |
"subterms (Minus a) = insert (Minus a) (subterms a)" |
"subterms Pi = {Pi}" |
"subterms (Var v) = {Var v}" |
"subterms (Num n) = {Num n}"

lemma subterms_self[simp]: "fa2 ∈ subterms fa2"
  by (induction fa2) auto

lemma interpret_floatarith_FDERIV_floatarith_eucl_of_env:― ‹TODO: cleanup, reduce to DERIV?!›
  assumes iD: "⋀i. i < DIM('a) ⟹ isDERIV (xs ! i) fa vs"
  assumes ds_fresh: "freshs_floatarith fa ds"
  assumes [simp]: "length xs = DIM ('a)" "length ds = DIM ('a)"
    "⋀i. i ∈ set xs ⟹ i < length vs" "distinct xs"
    "⋀i. i ∈ set ds ⟹ i < length vs" "distinct ds"
  shows "((λx::'a::executable_euclidean_space.
    (interpret_floatarith fa (list_updates xs (list_of_eucl x) vs))) has_derivative
    (λd. interpret_floatarith (FDERIV_floatarith fa xs (map Var ds)) (list_updates ds (list_of_eucl d) vs) )
    ) (at (eucl_of_env xs vs))"
  using iD ds_fresh
proof (induction fa)
  case (Add fa1 fa2)
  then show ?case
    by (auto intro!: derivative_eq_intros simp: FDERIV_floatarith_def interpret_floatarith_inner_floatariths 
        interpret_floatariths_map algebra_simps list_of_eucl_coord_update[symmetric])
next
  case (Minus fa)
  then show ?case
    by (auto intro!: derivative_eq_intros simp: FDERIV_floatarith_def interpret_floatarith_inner_floatariths 
        interpret_floatariths_map algebra_simps list_of_eucl_coord_update[symmetric])
next
  case (Mult fa1 fa2)
  then show ?case
    by (auto intro!: derivative_eq_intros simp: FDERIV_floatarith_def interpret_floatarith_inner_floatariths 
        interpret_floatariths_map algebra_simps list_of_eucl_coord_update[symmetric])
next
  case (Inverse fa)
  then show ?case
    by (force intro!: derivative_eq_intros DIM_positive simp: FDERIV_floatarith_def interpret_floatarith_inner_floatariths 
        interpret_floatariths_map algebra_simps list_of_eucl_coord_update[symmetric] power2_eq_square)
next
  case (Cos fa)
  then show ?case
    by (auto intro!: derivative_eq_intros ext simp: FDERIV_floatarith_def interpret_floatarith_inner_floatariths 
        interpret_floatariths_map add.commute minus_sin_cos_eq
        simp flip: mult_minus_left list_of_eucl_coord_update cos_pi_minus)
next
  case (Arctan fa)
  then show ?case
    by (auto intro!: derivative_eq_intros simp: FDERIV_floatarith_def interpret_floatarith_inner_floatariths 
        interpret_floatariths_map algebra_simps list_of_eucl_coord_update[symmetric])
next
  case (Abs fa)
  then show ?case
    by (auto intro!: derivative_eq_intros DIM_positive simp: FDERIV_floatarith_def interpret_floatarith_inner_floatariths 
        interpret_floatariths_map algebra_simps list_of_eucl_coord_update[symmetric] )
next
  case (Max fa1 fa2)
  then show ?case
    by (auto intro!: derivative_eq_intros DIM_positive simp: FDERIV_floatarith_def interpret_floatarith_inner_floatariths 
        interpret_floatariths_map algebra_simps list_of_eucl_coord_update[symmetric] )
next
  case (Min fa1 fa2)
  then show ?case
    by (auto intro!: derivative_eq_intros DIM_positive simp: FDERIV_floatarith_def interpret_floatarith_inner_floatariths 
        interpret_floatariths_map algebra_simps list_of_eucl_coord_update[symmetric] )
next
  case Pi
  then show ?case
    by (auto intro!: derivative_eq_intros DIM_positive simp: FDERIV_floatarith_def interpret_floatarith_inner_floatariths 
        interpret_floatariths_map algebra_simps list_of_eucl_coord_update[symmetric] )
next
  case (Sqrt fa)
  then show ?case
    by (force intro!: derivative_eq_intros DIM_positive simp: FDERIV_floatarith_def interpret_floatarith_inner_floatariths 
        interpret_floatariths_map algebra_simps list_of_eucl_coord_update[symmetric] )
next
  case (Exp fa)
  then show ?case
    by (auto intro!: derivative_eq_intros DIM_positive simp: FDERIV_floatarith_def interpret_floatarith_inner_floatariths 
        interpret_floatariths_map algebra_simps list_of_eucl_coord_update[symmetric] )
next
  case (Powr fa1 fa2)
  then show ?case
    by (force intro!: derivative_eq_intros DIM_positive simp: FDERIV_floatarith_def interpret_floatarith_inner_floatariths 
        interpret_floatariths_map algebra_simps divide_simps list_of_eucl_coord_update[symmetric] )
next
  case (Ln fa)
  then show ?case
    by (force intro!: derivative_eq_intros DIM_positive simp: FDERIV_floatarith_def interpret_floatarith_inner_floatariths 
        interpret_floatariths_map algebra_simps list_of_eucl_coord_update[symmetric] )
next
  case (Power fa x2a)
  then show ?case
    apply (cases x2a)
    apply (auto intro!: DIM_positive derivative_eq_intros simp: FDERIV_floatarith_def interpret_floatarith_inner_floatariths 
        interpret_floatariths_map algebra_simps list_of_eucl_coord_update[symmetric])
    apply (auto intro!: ext simp: )
    by (simp add: semiring_normalization_rules(27))
next
  case (Floor fa)
  then show ?case
    by (force intro!: derivative_eq_intros DIM_positive simp: FDERIV_floatarith_def interpret_floatarith_inner_floatariths 
        interpret_floatariths_map algebra_simps list_of_eucl_coord_update[symmetric] )
next
  case (Var x)
  then show ?case
    apply (auto intro!: derivative_eq_intros DIM_positive simp: FDERIV_floatarith_def interpret_floatarith_inner_floatariths 
        interpret_floatariths_map algebra_simps list_of_eucl_coord_update[symmetric] if_distrib)
    apply (subst list_updates_nth)
      apply (auto intro!: derivative_eq_intros ext split: if_splits
        cong: if_cong simp: if_distribR eucl_of_list_if)
    apply (subst inner_commute)
    apply (rule arg_cong[where f="λb. a ∙ b" for a])
    apply (auto intro!: euclidean_eqI[where 'a='a] simp: eucl_of_list_inner list_updates_nth index_nth_id)
    done
next
  case (Num x)
  then show ?case
    by (auto intro!: derivative_eq_intros DIM_positive simp: FDERIV_floatarith_def interpret_floatarith_inner_floatariths 
        interpret_floatariths_map algebra_simps list_of_eucl_coord_update[symmetric] )
qed

lemma interpret_floatarith_FDERIV_floatarith_append:
  assumes iD: "⋀i j. i < DIM('a) ⟹ isDERIV i (fa) (list_of_eucl x @ params)"
  assumes m: "max_Var_floatarith fa ≤ DIM('a) + length params"
  shows "((λx::'a::executable_euclidean_space.
      interpret_floatarith fa (list_of_eucl x @ params)) has_derivative
        (λd. interpret_floatarith
         (FDERIV_floatarith fa [0..<DIM('a)] (map Var [length params + DIM('a)..<length params + 2*DIM('a)]))
         (list_of_eucl x @ params @ list_of_eucl d))) (at x)"
proof -
  have m_nth: "ia < max_Var_floatarith fa ⟹ ia < DIM('a) + length params" for ia
    using less_le_trans m by blast
  have "((λxa::'a. interpret_floatarith fa
           (list_updates [0..<DIM('a)] (list_of_eucl xa) (list_of_eucl x @ params @ replicate DIM('a) 0))) has_derivative
   (λd. interpret_floatarith (FDERIV_floatarith fa [0..<DIM('a)] (map Var [length params + DIM('a)..<length params + 2 * DIM('a)]))
          (list_updates [length params + DIM('a)..<length params + 2 * DIM('a)] (list_of_eucl d)
            (list_of_eucl x @ params @ replicate DIM('a) 0))))
   (at (eucl_of_env [0..<DIM('a)] (list_of_eucl x @ params @ replicate DIM('a) 0)))"
    by (rule interpret_floatarith_FDERIV_floatarith_eucl_of_env)
      (auto intro!: iD freshs_floatarith_max_Var_floatarithI isDERIV_max_Var_floatarithI[OF iD]
        max_Var_floatarith_le_max_Var_floatariths[THEN order_trans] m[THEN order_trans]
        simp: nth_append add.commute less_diff_conv2 m_nth)
  moreover have "interpret_floatarith fa (list_updates [0..<DIM('a)] (list_of_eucl xa) (list_of_eucl x @ params @ replicate DIM('a) 0)) =
    interpret_floatarith fa (list_of_eucl xa @ params)" for xa::'a
    apply (auto intro!: nth_equalityI interpret_floatarith_max_Var_cong simp: )
    apply (auto simp: list_updates_nth nth_append dest: m_nth)
    done
  moreover have "(list_updates [length params + DIM('a)..<length params + 2 * DIM('a)] (list_of_eucl d) (list_of_eucl x @ params @ replicate DIM('a) 0)) =
    (list_of_eucl x @ params @ list_of_eucl d)" for d::'a
    by (auto simp: intro!: nth_equalityI simp: list_updates_nth nth_append add.commute)
  moreover have "(eucl_of_env [0..<DIM('a)] (list_of_eucl x @ params @ replicate DIM('a) 0)) = x"
    by (auto intro!: euclidean_eqI[where 'a='a] simp: eucl_of_env_def eucl_of_list_inner nth_append)
  ultimately show ?thesis by simp
qed

lemma interpret_floatarith_FDERIV_floatarith:
  assumes iD: "⋀i j. i < DIM('a) ⟹ isDERIV i (fa) (list_of_eucl x)"
  assumes m: "max_Var_floatarith fa ≤ DIM('a)"
  shows "((λx::'a::executable_euclidean_space.
      interpret_floatarith fa (list_of_eucl x)) has_derivative
        (λd. interpret_floatarith
         (FDERIV_floatarith fa [0..<DIM('a)] (map Var [DIM('a)..<2*DIM('a)]))
         (list_of_eucl x @ list_of_eucl d))) (at x)"
  using interpret_floatarith_FDERIV_floatarith_append[where params=Nil,simplified, OF assms]
  by simp

lemma interpret_floatarith_eventually_isDERIV:
  assumes iD: "⋀i j. i < DIM('a) ⟹ isDERIV i fa (list_of_eucl x @ params)"
  assumes m: "max_Var_floatarith fa ≤ DIM('a::executable_euclidean_space) + length params"
  shows "∀i < DIM('a). ∀⇩_F (x::'a) in at x. isDERIV i fa (list_of_eucl x @ params)"
  using iD m
proof (induction fa)
  case (Inverse fa)
  then have "∀i<DIM('a). ∀⇩_F x in at x. isDERIV i fa (list_of_eucl x @ params)"
    by auto
  moreover
  have iD: "i < DIM('a) ⟹ isDERIV i fa (list_of_eucl x @ params)" "interpret_floatarith fa (list_of_eucl x @ params) ≠ 0" for i
    using Inverse.prems(1)[OF ] by force+
  from Inverse have m: "max_Var_floatarith fa ≤ DIM('a) + length params" by simp
  from has_derivative_continuous[OF interpret_floatarith_FDERIV_floatarith_append, OF iD(1) m]
  have "isCont (λx. interpret_floatarith fa (list_of_eucl x @ params)) x" by simp
  then have "∀⇩_F x in at x. interpret_floatarith fa (list_of_eucl x @ params) ≠ 0"
    using iD(2) tendsto_imp_eventually_ne
    by (auto simp: isCont_def)
  ultimately
  show ?case
    by (auto elim: eventually_elim2)
next
  case (Sqrt fa)
  then have "∀i<DIM('a). ∀⇩_F x in at x. isDERIV i fa (list_of_eucl x @ params)"
    by auto
  moreover
  have iD: "i < DIM('a) ⟹ isDERIV i fa (list_of_eucl x @ params)" "interpret_floatarith fa (list_of_eucl x @ params) > 0" for i
    using Sqrt.prems(1)[OF ] by force+
  from Sqrt have m: "max_Var_floatarith fa ≤ DIM('a) + length params" by simp
  from has_derivative_continuous[OF interpret_floatarith_FDERIV_floatarith_append, OF iD(1) m]
  have "isCont (λx. interpret_floatarith fa (list_of_eucl x @ params)) x" by simp
  then have "∀⇩_F x in at x. interpret_floatarith fa (list_of_eucl x @ params) > 0"
    using iD(2) order_tendstoD
    by (auto simp: isCont_def)
  ultimately
  show ?case
    by (auto elim: eventually_elim2)
next
  case (Powr fa1 fa2)
  then have "∀i<DIM('a). ∀⇩_F x in at x. isDERIV i fa1 (list_of_eucl x @ params)"
    "∀i<DIM('a). ∀⇩_F x in at x. isDERIV i fa2 (list_of_eucl x @ params)"
    by auto
  moreover
  have iD: "i < DIM('a) ⟹ isDERIV i fa1 (list_of_eucl x @ params)" "interpret_floatarith fa1 (list_of_eucl x @ params) > 0"
    for i
    using Powr.prems(1) by force+
  from Powr have m: "max_Var_floatarith fa1 ≤ DIM('a) + length params" by simp
  from has_derivative_continuous[OF interpret_floatarith_FDERIV_floatarith_append, OF iD(1) m]
  have "isCont (λx. interpret_floatarith fa1 (list_of_eucl x @ params)) x" by simp
  then have "∀⇩_F x in at x. interpret_floatarith fa1 (list_of_eucl x @ params) > 0"
    using iD(2) order_tendstoD
    by (auto simp: isCont_def)
  ultimately
  show ?case
    apply safe
    subgoal for i
      apply (safe dest!: spec[of _ i])
      subgoal premises prems
        using prems(1,3,4)
        by eventually_elim auto
      done
    done
next
  case (Ln fa)
  then have "∀i<DIM('a). ∀⇩_F x in at x. isDERIV i fa (list_of_eucl x @ params)"
    by auto
  moreover
  have iD: "i < DIM('a) ⟹ isDERIV i fa (list_of_eucl x @ params)" "interpret_floatarith fa (list_of_eucl x @ params) > 0" for i
    using Ln.prems(1)[OF ] by force+
  from Ln have m: "max_Var_floatarith fa ≤ DIM('a) + length params" by simp
  from has_derivative_continuous[OF interpret_floatarith_FDERIV_floatarith_append, OF iD(1) m]
  have "isCont (λx. interpret_floatarith fa (list_of_eucl x @ params)) x" by simp
  then have "∀⇩_F x in at x. interpret_floatarith fa (list_of_eucl x @ params) > 0"
    using iD(2) order_tendstoD
    by (auto simp: isCont_def)
  ultimately
  show ?case
    by (auto elim: eventually_elim2)
next
  case (Power fa m) then show ?case by (cases m) auto
next
  case (Floor fa)
  then have "∀i<DIM('a). ∀⇩_F x in at x. isDERIV i fa (list_of_eucl x @ params)"
    by auto
  moreover
  have iD: "i < DIM('a) ⟹ isDERIV i fa (list_of_eucl x @ params)"
    "interpret_floatarith fa (list_of_eucl x @ params) ∉ ℤ" for i
    using Floor.prems(1)[OF ] by force+
  from Floor have m: "max_Var_floatarith fa ≤ DIM('a) + length params" by simp
  from has_derivative_continuous[OF interpret_floatarith_FDERIV_floatarith_append, OF iD(1) m]
  have cont: "isCont (λx. interpret_floatarith fa (list_of_eucl x @ params)) x" by simp
  let ?i = "λx. interpret_floatarith fa (list_of_eucl x @ params)"
  have "∀⇩_F y in at x. ?i y > floor (?i x)" "∀⇩_F y in at x. ?i y < ceiling (?i x)"
    using cont
    by (auto simp: isCont_def eventually_floor_less eventually_less_ceiling iD(2))
  then have "∀⇩_F x in at x. ?i x ∉ ℤ"
    apply eventually_elim
    apply (auto simp: Ints_def)
    by linarith
  ultimately
  show ?case
    by (auto elim: eventually_elim2)
qed (fastforce intro: DIM_positive elim: eventually_elim2)+

lemma eventually_isFDERIV:
  assumes iD: "isFDERIV DIM('a) [0..<DIM('a)] fas (list_of_eucl x@params)"
  assumes m: "max_Var_floatariths fas ≤ DIM('a::executable_euclidean_space) + length params"
  shows "∀⇩_F (x::'a) in at x. isFDERIV DIM('a) [0..<DIM('a)] fas (list_of_eucl x @ params)"
  by (auto simp: isFDERIV_def all_nat_less_eq eventually_ball_finite_distrib isFDERIV_lengthD[OF iD]
      intro!: interpret_floatarith_eventually_isDERIV[OF isFDERIV_uptD[OF iD], rule_format]
        max_Var_floatarith_le_max_Var_floatariths[THEN order_trans] m)

lemma isFDERIV_eventually_isFDERIV:
  assumes iD: "isFDERIV DIM('a) [0..<DIM('a)] fas (list_of_eucl x@params)"
  assumes m: "max_Var_floatariths fas ≤ DIM('a::executable_euclidean_space) + length params"
    shows "∀⇩_F (x::'a) in at x. isFDERIV DIM('a) [0..<DIM('a)] fas (list_of_eucl x @ params)"
  by (rule eventually_isFDERIV) (use assms in ‹auto simp: isFDERIV_def›)

lemma interpret_floatarith_FDERIV_floatariths_eucl_of_env:
  assumes iD: "isFDERIV DIM('a) xs fas vs"
  assumes fresh: "freshs_floatariths (fas) ds"
  assumes [simp]: "length ds = DIM ('a)"
    "⋀i. i ∈ set xs ⟹ i < length vs" "distinct xs"
    "⋀i. i ∈ set ds ⟹ i < length vs" "distinct ds"
  shows "((λx::'a::executable_euclidean_space.
    eucl_of_list
      (interpret_floatariths fas (list_updates xs (list_of_eucl x) vs))::'a) has_derivative
        (λd. eucl_of_list (interpret_floatariths
         (FDERIV_floatariths fas xs (map Var ds))
         (list_updates ds (list_of_eucl d) vs)))) (at (eucl_of_env xs vs))"
  by (subst has_derivative_componentwise_within)
    (auto simp add: eucl_of_list_inner isFDERIV_lengthD[OF iD]
      intro!: interpret_floatarith_FDERIV_floatarith_eucl_of_env iD[THEN isFDERIV_isDERIV_D]
        fresh_floatariths_fresh_floatarithI fresh)

lemma interpret_floatarith_FDERIV_floatariths_append:
  assumes iD: "isFDERIV DIM('a) [0..<DIM('a)] fas (list_of_eucl x @ ramsch)"
  assumes m: "max_Var_floatariths fas ≤ DIM('a) + length ramsch"
  assumes [simp]: "length fas = DIM('a)"
  shows "((λx::'a::executable_euclidean_space.
    eucl_of_list
      (interpret_floatariths fas (list_of_eucl x@ramsch))::'a) has_derivative
        (λd. eucl_of_list (interpret_floatariths
         (FDERIV_floatariths fas [0..<DIM('a)] (map Var [DIM('a)+length ramsch..<2*DIM('a) + length ramsch]))
         (list_of_eucl x @ ramsch @ list_of_eucl d)))) (at x)"
proof -
  have m_nth: "ia < max_Var_floatariths fas ⟹ ia < DIM('a) + length ramsch" for ia
    using m by simp
  have m_nth': "ia < max_Var_floatarith (fas ! j) ⟹ ia < DIM('a) + length ramsch" if "j < DIM('a)" for j ia
    using m_nth max_Var_floatariths_lessI that by auto

  have "((λxa::'a. eucl_of_list
         (interpret_floatariths fas
           (list_updates [0..<DIM('a)] (list_of_eucl xa)
             (list_of_eucl x @ ramsch @ replicate DIM('a) 0)))::'a) has_derivative
 (λd. eucl_of_list
        (interpret_floatariths
          (FDERIV_floatariths fas [0..<DIM('a)] (map Var [length ramsch + DIM('a)..<length ramsch + 2 * DIM('a)]))
          (list_updates [length ramsch + DIM('a)..<length ramsch + 2 * DIM('a)] (list_of_eucl d)
            (list_of_eucl x @ ramsch @ replicate DIM('a) 0)))))
 (at (eucl_of_env [0..<DIM('a)] (list_of_eucl x @ ramsch @ replicate DIM('a) 0)))"
    by (rule interpret_floatarith_FDERIV_floatariths_eucl_of_env[of
          "[0..<DIM('a)]" fas "list_of_eucl x@ramsch@replicate DIM('a) 0" "[length ramsch+DIM('a)..<length ramsch+2*DIM('a)]"])
       (auto intro!: iD[THEN isFDERIV_uptD] freshs_floatarith_max_Var_floatarithI isFDERIV_max_Var_congI[OF iD]
        max_Var_floatarith_le_max_Var_floatariths[THEN order_trans] m[THEN order_trans]
        freshs_floatariths_max_Var_floatarithsI simp: nth_append m add.commute less_diff_conv2 m_nth)
  moreover have "interpret_floatariths fas (list_updates [0..<DIM('a)] (list_of_eucl xa) (list_of_eucl x @ ramsch @ replicate DIM('a) 0)) =
    interpret_floatariths fas (list_of_eucl xa @ ramsch)" for xa::'a
    apply (auto intro!: nth_equalityI interpret_floatarith_max_Var_cong simp: )
    apply (auto simp: list_updates_nth nth_append dest: m_nth')
    done
  moreover have
    "(list_updates [DIM('a) + length ramsch..<length ramsch + 2 * DIM('a)]
        (list_of_eucl d)
        (list_of_eucl x @ ramsch @ replicate DIM('a) 0)) =
      (list_of_eucl x @ ramsch @ list_of_eucl d)" for d::'a
    by (auto simp: intro!: nth_equalityI simp: list_updates_nth nth_append)
  moreover have "(eucl_of_env [0..<DIM('a)] (list_of_eucl x @ ramsch @ replicate DIM('a) 0)) = x"
    by (auto intro!: euclidean_eqI[where 'a='a] simp: eucl_of_env_def eucl_of_list_inner nth_append)
  ultimately show ?thesis by (simp add: add.commute)
qed

lemma interpret_floatarith_FDERIV_floatariths:
  assumes iD: "isFDERIV DIM('a) [0..<DIM('a)] fas (list_of_eucl x)"
  assumes m: "max_Var_floatariths fas ≤ DIM('a)"
  assumes [simp]: "length fas = DIM('a)"
  shows "((λx::'a::executable_euclidean_space.
    eucl_of_list
      (interpret_floatariths fas (list_of_eucl x))::'a) has_derivative
        (λd. eucl_of_list (interpret_floatariths
         (FDERIV_floatariths fas [0..<DIM('a)] (map Var [DIM('a)..<2*DIM('a)]))
         (list_of_eucl x @ list_of_eucl d)))) (at x)"
  using interpret_floatarith_FDERIV_floatariths_append[where ramsch=Nil, simplified, OF assms]
  by simp

lemma continuous_on_min[continuous_intros]:
  fixes f g :: "'a::topological_space ⇒ 'b::linorder_topology"
  shows "continuous_on A f ⟹ continuous_on A g ⟹ continuous_on A (λx. min (f x) (g x))"
  by (auto simp: continuous_on_def intro!: tendsto_min)

lemmas [continuous_intros] = continuous_on_max
lemma continuous_on_if_const[continuous_intros]:
  "continuous_on s f ⟹ continuous_on s g ⟹ continuous_on s (λx. if p then f x else g x)"
  by (cases p) auto

lemma continuous_on_floatarith:
  assumes "continuous_on_floatarith fa" "length xs = DIM('a)" "distinct xs"
  shows "continuous_on UNIV (λx. interpret_floatarith fa (list_updates xs (list_of_eucl (x::'a::executable_euclidean_space)) vs))"
  using assms
  by (induction fa)
    (auto intro!: continuous_intros split: if_splits simp: list_updates_nth list_of_eucl_nth_if)

fun open_form :: "form ⇒ bool" where
"open_form (Bound x a b f)  = False" |
"open_form (Assign x a f)   = False" |
"open_form (Less a b) ⟷ continuous_on_floatarith a ∧ continuous_on_floatarith b" |
"open_form (LessEqual a b)  = False" |
"open_form (AtLeastAtMost x a b) = False" |
"open_form (Conj f g) ⟷ open_form f ∧ open_form g" |
"open_form (Disj f g) ⟷ open_form f ∧ open_form g"

lemma open_form:
  assumes "open_form f" "length xs = DIM('a::executable_euclidean_space)" "distinct xs"
  shows "open (Collect (λx::'a. interpret_form f (list_updates xs (list_of_eucl x) vs)))"
  using assms
  by (induction f) (auto intro!: open_Collect_less continuous_on_floatarith open_Collect_conj open_Collect_disj)

primrec isnFDERIV where
  "isnFDERIV N fas xs ds vs 0 = True"
| "isnFDERIV N fas xs ds vs (Suc n) ⟷
    isFDERIV N xs (FDERIV_n_floatariths fas xs (map Var ds) n) vs ∧
    isnFDERIV N fas xs ds vs n"

lemma one_add_square_eq_0: "1 + (x)⇧² ≠ (0::real)"
  by (sos "((R<1 + (([~1] * A=0) + (R<1 * (R<1 * [x]^2)))))")

lemma isDERIV_fold_const_fa[intro]:
  assumes "isDERIV x fa vs"
  shows "isDERIV x (fold_const_fa fa) vs"
  using assms
  apply (induction fa)
  subgoal by (auto simp: fold_const_fa.simps split: floatarith.splits option.splits)
  subgoal by (auto simp: fold_const_fa.simps split: floatarith.splits)
  subgoal by (auto simp: fold_const_fa.simps split: floatarith.splits option.splits)
  subgoal by (auto simp: fold_const_fa.simps split: floatarith.splits)
  subgoal by (auto simp: fold_const_fa.simps split: floatarith.splits)
  subgoal by (auto simp: fold_const_fa.simps split: floatarith.splits)
  subgoal by (auto simp: fold_const_fa.simps split: floatarith.splits)
  subgoal by (auto simp: fold_const_fa.simps split: floatarith.splits)
  subgoal by (auto simp: fold_const_fa.simps split: floatarith.splits)
  subgoal by (auto simp: fold_const_fa.simps split: floatarith.splits)
  subgoal by (auto simp: fold_const_fa.simps split: floatarith.splits)
  subgoal by (auto simp: fold_const_fa.simps split: floatarith.splits)
  subgoal by (auto simp: fold_const_fa.simps split: floatarith.splits)
  subgoal by (auto simp: fold_const_fa.simps split: floatarith.splits)
  subgoal for fa n
    by (cases n) (auto simp: fold_const_fa.simps split: floatarith.splits nat.splits)
  subgoal
    by (auto simp: fold_const_fa.simps split: floatarith.splits) (subst (asm) fold_const_fa[symmetric], force)+
  subgoal by (auto simp: fold_const_fa.simps split: floatarith.splits)
  subgoal by (auto simp: fold_const_fa.simps split: floatarith.splits)
  done

lemma isDERIV_fold_const_fa_minus[intro!]:
  assumes "isDERIV x (fold_const_fa fa) vs"
  shows "isDERIV x (fold_const_fa (Minus fa)) vs"
  using assms
  by (induction fa) (auto simp: fold_const_fa.simps split: floatarith.splits)

lemma isDERIV_fold_const_fa_plus[intro!]:
  assumes "isDERIV x (fold_const_fa fa) vs"
  assumes "isDERIV x (fold_const_fa fb) vs"
  shows "isDERIV x (fold_const_fa (Add fa fb)) vs"
  using assms
  by (induction fa)
    (auto simp: fold_const_fa.simps
      split: floatarith.splits option.splits)

lemma isDERIV_fold_const_fa_mult[intro!]:
  assumes "isDERIV x (fold_const_fa fa) vs"
  assumes "isDERIV x (fold_const_fa fb) vs"
  shows "isDERIV x (fold_const_fa (Mult fa fb)) vs"
  using assms
  by (induction fa)
    (auto simp: fold_const_fa.simps
      split: floatarith.splits option.splits)

lemma isDERIV_fold_const_fa_power[intro!]:
  assumes "isDERIV x (fold_const_fa fa) vs"
  shows "isDERIV x (fold_const_fa (fa ^⇩_e n)) vs"
  apply (cases n, simp add: fold_const_fa.simps split: floatarith.splits)
  using assms
  by (induction fa)
    (auto simp: fold_const_fa.simps split: floatarith.splits option.splits)

lemma isDERIV_fold_const_fa_inverse[intro!]:
  assumes "isDERIV x (fold_const_fa fa) vs"
  assumes "interpret_floatarith fa vs ≠ 0"
  shows "isDERIV x (fold_const_fa (Inverse fa)) vs"
  using assms
  by (simp add: fold_const_fa.simps)

lemma add_square_ne_zero[simp]: "(y::'a::linordered_idom) > 0 ⟹ y + x⇧² ≠ 0"
  by auto (metis less_add_same_cancel2 power2_less_0)

lemma isDERIV_FDERIV_floatarith:
  assumes "isDERIV x fa vs" "⋀i. i < length ds ⟹ isDERIV x (ds ! i) vs"
  assumes [simp]: "length xs = length ds"
  shows "isDERIV x (FDERIV_floatarith fa xs ds) vs"
  using assms
  apply (induction fa)
  subgoal by (auto simp: FDERIV_floatarith_def isDERIV_inner_iff)
  subgoal by (auto simp: FDERIV_floatarith_def isDERIV_inner_iff)
  subgoal by (auto simp: FDERIV_floatarith_def isDERIV_inner_iff)
  subgoal by (auto simp: FDERIV_floatarith_def isDERIV_inner_iff)
  subgoal by (auto simp: FDERIV_floatarith_def isDERIV_inner_iff)
  subgoal by (auto simp: FDERIV_floatarith_def isDERIV_inner_iff)
  subgoal by (auto simp: FDERIV_floatarith_def isDERIV_inner_iff)
  subgoal by (auto simp: FDERIV_floatarith_def isDERIV_inner_iff)
  subgoal by (auto simp: FDERIV_floatarith_def isDERIV_inner_iff)
  subgoal by (auto simp: FDERIV_floatarith_def isDERIV_inner_iff)
  subgoal by (auto simp: FDERIV_floatarith_def isDERIV_inner_iff)
  subgoal by (auto simp: FDERIV_floatarith_def isDERIV_inner_iff)
  subgoal by (auto simp: FDERIV_floatarith_def isDERIV_inner_iff)
  subgoal by (auto simp: FDERIV_floatarith_def isDERIV_inner_iff)
  subgoal for fa n by (cases n) (auto simp: FDERIV_floatarith_def isDERIV_inner_iff)
  subgoal by (auto simp: FDERIV_floatarith_def isDERIV_inner_iff)
  subgoal by (auto simp: FDERIV_floatarith_def isDERIV_inner_iff)
  subgoal by (auto simp: FDERIV_floatarith_def isDERIV_inner_iff)
  done

lemma isDERIV_FDERIV_floatariths:
  assumes "isFDERIV N xs fas vs" "isFDERIV N xs ds vs" and [simp]: "length fas = length ds"
  shows "isFDERIV N xs (FDERIV_floatariths fas xs ds) vs"
  using assms
  by (auto simp: isFDERIV_def FDERIV_floatariths_def intro!: isDERIV_FDERIV_floatarith)

lemma isFDERIV_imp_isFDERIV_FDERIV_n:
  assumes "length fas = length ds"
  shows "isFDERIV N xs fas vs ⟹ isFDERIV N xs ds vs ⟹
    isFDERIV N xs (FDERIV_n_floatariths fas xs ds n) vs"
  using assms
  by (induction n) (auto intro!: isDERIV_FDERIV_floatariths)

lemma isFDERIV_map_Var:
  assumes [simp]: "length ds = N" "length xs = N"
  shows "isFDERIV N xs (map Var ds) vs"
  by (auto simp: isFDERIV_def)

theorem isFDERIV_imp_isnFDERIV:
  assumes "isFDERIV N xs fas vs" and [simp]: "length fas = N" "length xs = N" "length ds = N"
  shows "isnFDERIV N fas xs ds vs n"
  using assms
  by (induction n) (auto intro!: isFDERIV_imp_isFDERIV_FDERIV_n isFDERIV_map_Var)

lemma eventually_isnFDERIV:
  assumes iD: "isnFDERIV DIM('a) fas [0..<DIM('a)] [DIM('a)..<2*DIM('a)] (list_of_eucl x @ list_of_eucl (d::'a)) n"
  assumes m: "max_Var_floatariths fas ≤ 2 * DIM('a::executable_euclidean_space)"
  shows "∀⇩_F (x::'a) in at x. isnFDERIV DIM('a) fas [0..<DIM('a)] [DIM('a)..<2*DIM('a)] (list_of_eucl x @ list_of_eucl d) n"
  using iD
proof (induction n)
  case (Suc n)
  then have 1: "∀⇩_F x in at x. isnFDERIV DIM('a) fas [0..<DIM('a)] [DIM('a)..<2 * DIM('a)] (list_of_eucl x @ list_of_eucl d) n"
    and 2: "isFDERIV DIM('a) [0..<DIM('a)] (FDERIV_n_floatariths fas [0..<DIM('a)] (map Var [DIM('a)..<2 * DIM('a)]) n)
      (list_of_eucl x @ list_of_eucl d)"
    by simp_all
  have "max_Var_floatariths (FDERIV_n_floatariths fas [0..<DIM('a)] (map Var [DIM('a)..<2 * DIM('a)]) n) ≤
      DIM('a) + length (list_of_eucl d)"
    by (auto intro!: max_Var_floatarith_FDERIV_n_floatariths[THEN order_trans] m[THEN order_trans])
  from eventually_isFDERIV[OF 2 this] 1
  show ?case
    by eventually_elim simp
qed simp

lemma isFDERIV_open:
  assumes "max_Var_floatariths fas ≤ DIM('a)"
  shows "open {x::'a. isFDERIV DIM('a::executable_euclidean_space)  [0..<DIM('a)] fas (list_of_eucl x)}"
    (is "open (Collect ?s)")
proof (safe intro!: topological_space_class.openI)
  fix x::'a assume x: "?s x"
  with eventually_isFDERIV[where 'a='a, of fas x Nil]
  have "∀⇩_F x in at x. x ∈ Collect ?s"
    by (auto simp: assms)
  then obtain S where "open S" "x ∈ S"
    "(∀xa∈S. xa ≠ x ⟶ ?s xa)"
    unfolding eventually_at_topological
    by auto
  with x show "∃T. open T ∧ x ∈ T ∧ T ⊆ Collect ?s"
    by (auto intro!: exI[where x=S])
qed

lemma interpret_floatarith_FDERIV_floatarith_eq:
  assumes [simp]: "length xs = DIM('a::executable_euclidean_space)" "length ds = DIM('a)"
  shows "interpret_floatarith (FDERIV_floatarith fa xs ds) vs =
    einterpret (map (λx. DERIV_floatarith x fa) xs) vs ∙ (einterpret ds vs::'a)"
  by (auto simp: FDERIV_floatarith_def interpret_floatarith_inner_floatariths)

lemma
  interpret_floatariths_FDERIV_floatariths_cong:
  assumes [simp]: "length d1s = DIM('a::executable_euclidean_space)" "length d2s = DIM('a)" "length fas1 = length fas2"
  assumes fresh1: "freshs_floatariths fas1 d1s"
  assumes fresh2: "freshs_floatariths fas2 d2s"
  assumes eq1: "⋀i. i < length fas1 ⟹ interpret_floatariths (map (λx. DERIV_floatarith x (fas1 ! i)) [0..<DIM('a)]) xs1 =
    interpret_floatariths (map (λx. DERIV_floatarith x (fas2 ! i)) [0..<DIM('a)]) xs2"
  assumes eq2: "⋀i. i < DIM('a) ⟹ xs1 ! (d1s ! i) = xs2 ! (d2s ! i)"
  shows "interpret_floatariths (FDERIV_floatariths fas1 [0..<DIM('a)] (map floatarith.Var d1s)) xs1 =
    interpret_floatariths (FDERIV_floatariths fas2 [0..<DIM('a)] (map floatarith.Var d2s)) xs2"
proof -
  note eq1
  moreover have "interpret_floatariths (map Var d1s) (xs1) =
    interpret_floatariths (map Var d2s) (xs2)"
    by (auto intro!: nth_equalityI eq2)
  ultimately
  show ?thesis
    by (auto intro!: nth_equalityI simp: interpret_floatarith_FDERIV_floatarith_eq)
qed

lemma subst_floatarith_Var_DERIV_floatarith:
  assumes "⋀x. x = n ⟷ s x = n"
  shows "subst_floatarith (λx. Var (s x)) (DERIV_floatarith n fa) =
  DERIV_floatarith n (subst_floatarith (λx. Var (s x)) fa)"
  using assms
proof (induction fa)
  case (Power fa n)
  then show ?case by (cases n) auto
qed force+

lemma subst_floatarith_inner_floatariths[simp]:
  assumes "length fs = length gs"
  shows "subst_floatarith s (inner_floatariths fs gs) =
      inner_floatariths (map (subst_floatarith s) fs) (map (subst_floatarith s) gs)"
  using assms
  by (induction rule: list_induct2) auto

fun_cases subst_floatarith_Num: "subst_floatarith s fa = Num y"
  and subst_floatarith_Add: "subst_floatarith s fa = Add x y"
  and subst_floatarith_Minus: "subst_floatarith s fa = Minus y"

lemma Num_eq_subst_Var[simp]: "Num x = subst_floatarith (λx. Var (s x)) fa ⟷ fa = Num x"
  by (cases fa) auto

lemma Add_eq_subst_VarE:
  assumes "Add fa1 fa2 = subst_floatarith (λx. Var (s x)) fa"
  obtains a1 a2 where "fa = Add a1 a2" "fa1 = subst_floatarith (λx. Var (s x)) a1"
      "fa2 = subst_floatarith (λx. Var (s x)) a2"
  using assms
  by (cases fa) auto

lemma subst_floatarith_eq_self[simp]: "subst_floatarith s f = f" if "max_Var_floatarith f = 0"
  using that by (induction f) auto

lemma fold_const_fa_unique: "False" if "(⋀x. f = Num x)"
  using that[of 0] that[of 1]
  by auto

lemma zero_unique: False if "(⋀x::float. x = 0)"
  using that[of 0] that[of 1]
  by auto

lemma fold_const_fa_Mult_eq_NumE:
  assumes "fold_const_fa (Mult a b) = Num x"
  obtains y z where "fold_const_fa a = Num y" "fold_const_fa b = Num z" "x = y * z"
  | y where "fold_const_fa a = Num 0" "x = 0"
  | y where "fold_const_fa b = Num 0" "x = 0"
  using assms
  by atomize_elim (auto simp: fold_const_fa.simps split!: option.splits if_splits
      elim!: dest_Num_fa_Some dest_Num_fa_None)

lemma fold_const_fa_Add_eq_NumE:
  assumes "fold_const_fa (Add a b) = Num x"
  obtains y z where "fold_const_fa a = Num y" "fold_const_fa b = Num z" "x = y + z"
  using assms
  by atomize_elim (auto simp: fold_const_fa.simps split!: option.splits if_splits
      elim!: dest_Num_fa_Some dest_Num_fa_None)

lemma subst_floatarith_Var_fold_const_fa[symmetric]:
  "fold_const_fa (subst_floatarith (λx. Var (s x)) fa) =
  subst_floatarith (λx. Var (s x)) (fold_const_fa fa)"
proof (induction fa)
  case (Add fa1 fa2)
  then show ?case
    apply (auto simp: fold_const_fa.simps
        split!: floatarith.splits option.splits if_splits
        elim!: dest_Num_fa_Some)
    apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3))
    apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3))
    apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3))
    apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3))
    apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3))
    apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3))
    apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3))
    apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3))
    apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3))
    apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3))
    done
next
  case (Mult fa1 fa2)
  then show ?case
    apply (auto simp: fold_const_fa.simps
        split!: floatarith.splits option.splits if_splits
        elim!: dest_Num_fa_Some)
    apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3))
    apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3))
    apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3))
    apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3))
    apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3))
    apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3))
    apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3))
    apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3))
    apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3))
    apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3))
    apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3))
    apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3))
    apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3))
    apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3))
    apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3))
    done
next
  case (Min)
  then show ?case
    by (auto simp: fold_const_fa.simps split: floatarith.splits)
next
  case (Max)
  then show ?case
    by (auto simp: fold_const_fa.simps split: floatarith.splits)
qed (auto simp: fold_const_fa.simps
        split!: floatarith.splits option.splits if_splits
        elim!: dest_Num_fa_Some)

lemma subst_floatarith_eq_Num[simp]: "(subst_floatarith (λx. Var (s x)) fa = Num x) ⟷ fa = Num x"
  by (induction fa) (auto simp: )

lemma fold_const_fa_subst_eq_Num0_iff[simp]:
  "fold_const_fa (subst_floatarith (λx. Var (s x)) fa) = Num x ⟷ fold_const_fa fa = Num x"
  unfolding subst_floatarith_Var_fold_const_fa[symmetric]
  by simp

lemma subst_floatarith_Var_FDERIV_floatarith:
  assumes len: "length xs = DIM('a::executable_euclidean_space)" and [simp]: "length ds = DIM('a)"
  assumes eq: "⋀x y. x ∈ set xs ⟹ (y = x) = (s y = x)"
  shows "subst_floatarith (λx. Var (s x)) (FDERIV_floatarith fa xs ds) =
    (FDERIV_floatarith (subst_floatarith (λx. Var (s x)) fa) xs (map (subst_floatarith (λx. Var (s x))) ds))"
proof -
  have [simp]: "⋀x. x ∈ set xs ⟹ subst_floatarith (λx. Var (s x)) (DERIV_floatarith x fa1) =
    (DERIV_floatarith x (subst_floatarith (λx. Var (s x)) fa1))"
    for fa1
    by (rule subst_floatarith_Var_DERIV_floatarith) (rule eq)
  have map_eq: "(map (λxa. if xa = s x then Num 1 else Num 0) xs) =
      (map (λxa. if xa = x then Num 1 else Num 0) xs)"
    for x
    apply (subst map_eq_conv)
    using eq[of x x] eq[of "s x"]
    by (auto simp: )
  show ?thesis
    using len
    by (induction fa)
      (auto simp: FDERIV_floatarith_def o_def if_distrib
        subst_floatarith_Var_fold_const_fa fold_const_fa.simps(18) map_eq
        cong: map_cong if_cong)
qed

lemma subst_floatarith_Var_FDERIV_n_nth:
  assumes len: "length xs = DIM('a::executable_euclidean_space)" and [simp]: "length ds = DIM('a)"
  assumes eq: "⋀x y. x ∈ set xs ⟹ (y = x) = (s y = x)"
  assumes [simp]: "i < length fas"
  shows "subst_floatarith (λx. Var (s x)) (FDERIV_n_floatariths fas xs ds n ! i) =
    (FDERIV_n_floatariths (map (subst_floatarith (λx. Var (s x))) fas) xs (map (subst_floatarith (λx. Var (s x))) ds) n ! i)"
proof (induction n)
  case (Suc n)
  show ?case
    by (simp add: subst_floatarith_Var_FDERIV_floatarith[OF len _ eq] Suc.IH[symmetric])
qed simp

lemma subst_floatarith_Var_max_Var_floatarith:
  assumes "⋀i. i < max_Var_floatarith fa ⟹ s i = i"
  shows "subst_floatarith (λi. Var (s i)) fa = fa"
  using assms
  by (induction fa) auto

lemma interpret_floatarith_subst_floatarith_idem:
  assumes mv: "max_Var_floatarith fa ≤ length vs"
  assumes idem: "⋀j. j < max_Var_floatarith fa ⟹ vs ! s j = vs ! j"
  shows "interpret_floatarith (subst_floatarith (λi. Var (s i)) fa) vs = interpret_floatarith fa vs"
  using assms
  by (induction fa) auto

lemma isDERIV_subst_Var_floatarith:
  assumes mv: "max_Var_floatarith fa ≤ length vs"
  assumes idem: "⋀j. j < max_Var_floatarith fa ⟹ vs ! s j = vs ! j"
  assumes "⋀j. s j = i ⟷ j = i"
  shows "isDERIV i (subst_floatarith (λi. Var (s i)) fa) vs = isDERIV i fa vs"
  using mv idem
proof (induction fa)
  case (Power fa n)
  then show ?case by (cases n) auto
qed (auto simp: interpret_floatarith_subst_floatarith_idem)

lemma isFDERIV_subst_Var_floatarith:
  assumes mv: "max_Var_floatariths fas ≤ length vs"
  assumes idem: "⋀j. j < max_Var_floatariths fas ⟹ vs ! (s j) = vs ! j"
  assumes "⋀i j. i ∈ set xs ⟹ s j = i ⟷ j = i"
  shows "isFDERIV n xs (map (subst_floatarith (λi. Var (s i))) fas) vs = isFDERIV n xs fas vs"
proof -
  have mv: "⋀i. i < length fas ⟹ max_Var_floatarith (fas ! i) ≤ length vs"
    apply (rule order_trans[OF _ mv])
    by (intro max_Var_floatarith_le_max_Var_floatariths_nth)
  have idem: "⋀i j. i < length fas ⟹ j < max_Var_floatarith (fas ! i) ⟹ vs ! s j = vs ! j"
    using idem
    by (auto simp: dest!: max_Var_floatariths_lessI)
  show ?thesis
    unfolding isFDERIV_def
    using mv idem assms(3)
    by (auto simp: isDERIV_subst_Var_floatarith)
qed

lemma interpret_floatariths_append[simp]:
  "interpret_floatariths (xs @ ys) vs = interpret_floatariths xs vs @ interpret_floatariths ys vs"
  by (induction xs) auto

lemma not_fresh_inner_floatariths:
  assumes "length xs = length ys"
  shows "¬ fresh_floatarith (inner_floatariths xs ys) i ⟷ ¬fresh_floatariths xs i ∨ ¬fresh_floatariths ys i"
  using assms
  by (induction xs ys rule: list_induct2) auto

lemma fresh_inner_floatariths:
  assumes "length xs = length ys"
  shows "fresh_floatarith (inner_floatariths xs ys) i ⟷ fresh_floatariths xs i ∧ fresh_floatariths ys i"
  using not_fresh_inner_floatariths assms by auto

lemma not_fresh_floatariths_map:
  " ¬ fresh_floatariths (map f xs) i ⟷ (∃x ∈ set xs. ¬fresh_floatarith (f x) i)"
  by (induction xs) auto

lemma fresh_floatariths_map:
  " fresh_floatariths (map f xs) i ⟷ (∀x ∈ set xs. fresh_floatarith (f x) i)"
  by (induction xs) auto

lemma fresh_floatarith_fold_const_fa: "fresh_floatarith fa i ⟹ fresh_floatarith (fold_const_fa fa) i"
  by (induction fa) (auto simp: fold_const_fa.simps split: floatarith.splits option.splits)

lemma fresh_floatarith_fold_const_fa_Add[intro!]:
  assumes "fresh_floatarith (fold_const_fa a) i" "fresh_floatarith (fold_const_fa b) i"
  shows "fresh_floatarith (fold_const_fa (Add a b)) i"
  using assms
  by (auto simp: fold_const_fa.simps split!: floatarith.splits option.splits)

lemma fresh_floatarith_fold_const_fa_Mult[intro!]:
  assumes "fresh_floatarith (fold_const_fa a) i" "fresh_floatarith (fold_const_fa b) i"
  shows "fresh_floatarith (fold_const_fa (Mult a b)) i"
  using assms
  by (auto simp: fold_const_fa.simps split!: floatarith.splits option.splits)

lemma fresh_floatarith_fold_const_fa_Minus[intro!]:
  assumes "fresh_floatarith (fold_const_fa b) i"
  shows "fresh_floatarith (fold_const_fa (Minus b)) i"
  using assms
  by (auto simp: fold_const_fa.simps split!: floatarith.splits)

lemma fresh_FDERIV_floatarith:
  "fresh_floatarith ode_e i ⟹ fresh_floatariths ds i
  ⟹ length ds = DIM('a)
  ⟹ fresh_floatarith (FDERIV_floatarith ode_e [0..<DIM('a::executable_euclidean_space)] ds) i"
proof (induction ode_e)
  case (Power ode_e n)
  then show ?case by (cases n) (auto simp: FDERIV_floatarith_def fresh_inner_floatariths fresh_floatariths_map fresh_floatarith_fold_const_fa)
qed (auto simp: FDERIV_floatarith_def fresh_inner_floatariths fresh_floatariths_map fresh_floatarith_fold_const_fa)

lemma not_fresh_FDERIV_floatarith:
  "¬ fresh_floatarith (FDERIV_floatarith ode_e [0..<DIM('a::executable_euclidean_space)] ds) i
  ⟹ length ds = DIM('a)
  ⟹ ¬fresh_floatarith ode_e i ∨ ¬fresh_floatariths ds i"
  using fresh_FDERIV_floatarith by auto

lemma not_fresh_FDERIV_floatariths:
  "¬ fresh_floatariths (FDERIV_floatariths ode_e [0..<DIM('a::executable_euclidean_space)] ds) i ⟹
  length ds = DIM('a) ⟹ ¬fresh_floatariths ode_e i ∨ ¬fresh_floatariths ds i"
  by (induction ode_e) (auto simp: FDERIV_floatariths_def dest!: not_fresh_FDERIV_floatarith)

lemma isDERIV_FDERIV_floatarith_linear:
  fixes x h::"'a::executable_euclidean_space"
  assumes "⋀k. k < DIM('a) ⟹ isDERIV i (DERIV_floatarith k fa) xs"
  assumes "max_Var_floatarith fa ≤ DIM('a)"
  assumes [simp]: "length xs = DIM('a)" "length hs = DIM('a)"
  shows "isDERIV i (FDERIV_floatarith fa [0..<DIM('a)] (map Var [DIM('a)..<2 * DIM('a)]))
            (xs @ hs)"
  using assms
  apply (auto simp: FDERIV_floatarith_def isDERIV_inner_iff)
  apply (rule isDERIV_max_Var_floatarithI) apply force
  apply (auto simp: nth_append)
  by (metis add_diff_inverse_nat leD max_Var_floatarith_DERIV_floatarith
      max_Var_floatarith_fold_const_fa trans_le_add1)

lemma
  isFDERIV_FDERIV_floatariths_linear:
  fixes x h::"'a::executable_euclidean_space"
  assumes "⋀i j k.
       i < DIM('a) ⟹
       j < DIM('a) ⟹ k < DIM('a) ⟹ isDERIV i (DERIV_floatarith k (fas ! j)) (xs)"
  assumes [simp]: "length fas = DIM('a::executable_euclidean_space)"
  assumes [simp]: "length xs = DIM('a)" "length hs = DIM('a)"
  assumes "max_Var_floatariths fas ≤ DIM('a)"
  shows "isFDERIV DIM('a) [0..<DIM('a::executable_euclidean_space)]
     (FDERIV_floatariths fas [0..<DIM('a)] (map floatarith.Var [DIM('a)..<2 * DIM('a)]))
     (xs @ hs)"
  apply (auto simp: isFDERIV_def intro!: isDERIV_FDERIV_floatarith_linear assms)
  using assms(5) max_Var_floatariths_lessI not_le_imp_less by fastforce

definition isFDERIV_approx where
  "isFDERIV_approx p n xs fas vs =
    ((∀i<n. ∀j<n. isDERIV_approx p (xs ! i) (fas ! j) vs) ∧ length fas = n ∧ length xs = n)"

lemma isFDERIV_approx:
  "bounded_by vs VS ⟹ isFDERIV_approx prec n xs fas VS ⟹ isFDERIV n xs fas vs"
  by (auto simp: isFDERIV_approx_def isFDERIV_def intro!: isDERIV_approx)

primrec isnFDERIV_approx where
  "isnFDERIV_approx p N fas xs ds vs 0 = True"
| "isnFDERIV_approx p N fas xs ds vs (Suc n) ⟷
    isFDERIV_approx p N xs (FDERIV_n_floatariths fas xs (map Var ds) n) vs ∧
    isnFDERIV_approx p N fas xs ds vs n"

lemma isnFDERIV_approx:
  "bounded_by vs VS ⟹ isnFDERIV_approx prec N fas xs ds VS n ⟹ isnFDERIV N fas xs ds vs n"
  by (induction n) (auto intro!: isFDERIV_approx)

fun plain_floatarith::"nat ⇒ floatarith ⇒ bool" where
  "plain_floatarith N (floatarith.Add a b) ⟷ plain_floatarith N a ∧ plain_floatarith N b"
| "plain_floatarith N (floatarith.Mult a b) ⟷ plain_floatarith N a ∧ plain_floatarith N b"
| "plain_floatarith N (floatarith.Minus a) ⟷ plain_floatarith N a"
| "plain_floatarith N (floatarith.Pi) ⟷ True"
| "plain_floatarith N (floatarith.Num n) ⟷ True"
| "plain_floatarith N (floatarith.Var i) ⟷ i < N"
| "plain_floatarith N (floatarith.Max a b) ⟷ plain_floatarith N a ∧ plain_floatarith N b"
| "plain_floatarith N (floatarith.Min a b) ⟷ plain_floatarith N a ∧ plain_floatarith N b"
| "plain_floatarith N (floatarith.Power a n) ⟷ plain_floatarith N a"
| "plain_floatarith N (floatarith.Cos a) ⟷ False" ― ‹TODO: should be plain!›
| "plain_floatarith N (floatarith.Arctan a) ⟷ False" ― ‹TODO: should be plain!›
| "plain_floatarith N (floatarith.Abs a) ⟷ plain_floatarith N a"
| "plain_floatarith N (floatarith.Exp a) ⟷ False" ― ‹TODO: should be plain!›
| "plain_floatarith N (floatarith.Sqrt a) ⟷ False" ― ‹TODO: should be plain!›
| "plain_floatarith N (floatarith.Floor a) ⟷ plain_floatarith N a"

| "plain_floatarith N (floatarith.Powr a b) ⟷ False"
| "plain_floatarith N (floatarith.Inverse a) ⟷ False"
| "plain_floatarith N (floatarith.Ln a) ⟷ False"

lemma plain_floatarith_approx_not_None:
  assumes "plain_floatarith N fa" "N ≤ length XS" "⋀i. i < N ⟹ XS ! i ≠ None"
  shows "approx p fa XS ≠ None"
  using assms
  by (induction fa)
    (auto simp: Let_def split_beta' prod_eq_iff approx.simps)


definition "Rad_of w = w * (Pi / Num 180)"
lemma interpret_Rad_of[simp]: "interpret_floatarith (Rad_of w) xs = rad_of (interpret_floatarith w xs)"
  by (auto simp: Rad_of_def rad_of_def)

definition "Deg_of w = Num 180 * w / Pi"
lemma interpret_Deg_of[simp]: "interpret_floatarith (Deg_of w) xs = deg_of (interpret_floatarith w xs)"
  by (auto simp: Deg_of_def deg_of_def inverse_eq_divide)

unbundle no_floatarith_notation

end

Theory Straight_Line_Program

section ‹Straight Line Programs›
theory Straight_Line_Program
  imports
    Floatarith_Expression
    Deriving.Derive
    "HOL-Library.Monad_Syntax"
    "HOL-Library.RBT_Mapping"
begin

unbundle floatarith_notation

derive (linorder) compare_order float

derive linorder floatarith

subsection ‹Definition›

type_synonym slp = "floatarith list"

primrec interpret_slp::"slp ⇒ real list ⇒ real list" where
  "interpret_slp [] = (λxs. xs)"
| "interpret_slp (ea # eas) = (λxs. interpret_slp eas (interpret_floatarith ea xs#xs))"

subsection ‹Reification as straight line program (with common subexpression elimination)›

definition "slp_index vs i = (length vs - Suc i)"

definition "slp_index_lookup vs M a = slp_index vs (the (Mapping.lookup M a))"

definition
  "slp_of_fa_bin Binop a b M slp M2 slp2 =
    (case Mapping.lookup M (Binop a b) of
        Some i ⇒ (Mapping.update (Binop a b) (length slp) M, slp@[Var (slp_index slp i)])
      | None ⇒ (Mapping.update (Binop a b) (length slp2) M2,
                slp2@[Binop (Var (slp_index_lookup slp2 M2 a)) (Var (slp_index_lookup slp2 M2 b))]))"

definition
  "slp_of_fa_un Unop a M slp M1 slp1 =
    (case Mapping.lookup M (Unop a) of
        Some i ⇒ (Mapping.update (Unop a) (length slp) M, slp@[Var (slp_index slp i)])
      | None ⇒ (Mapping.update (Unop a) (length slp1) M1,
                  slp1@[Unop (Var (slp_index_lookup slp1 M1 a))]))"

definition
  "slp_of_fa_cnst Const Const' M vs =
    (Mapping.update Const (length vs) M,
      vs @ [case Mapping.lookup M Const of Some i ⇒ Var (slp_index vs i) | None ⇒ Const'])"

fun slp_of_fa :: "floatarith ⇒ (floatarith, nat) mapping ⇒ floatarith list ⇒
  ((floatarith, nat) mapping × floatarith list)" where
"slp_of_fa (Add a b) M slp =
    (let (M1, slp1) = slp_of_fa a M slp; (M2, slp2) = slp_of_fa b M1 slp1 in
      slp_of_fa_bin Add a b M slp M2 slp2)"
| "slp_of_fa (Mult a b) M slp =
    (let (M1, slp1) = slp_of_fa a M slp; (M2, slp2) = slp_of_fa b M1 slp1 in
      slp_of_fa_bin Mult a b M slp M2 slp2)"
| "slp_of_fa (Min a b) M slp =
    (let (M1, slp1) = slp_of_fa a M slp; (M2, slp2) = slp_of_fa b M1 slp1 in
      slp_of_fa_bin Min a b M slp M2 slp2)"
| "slp_of_fa (Max a b) M slp =
    (let (M1, slp1) = slp_of_fa a M slp; (M2, slp2) = slp_of_fa b M1 slp1 in
      slp_of_fa_bin Max a b M slp M2 slp2)"
| "slp_of_fa (Powr a b) M slp =
    (let (M1, slp1) = slp_of_fa a M slp; (M2, slp2) = slp_of_fa b M1 slp1 in
      slp_of_fa_bin Powr a b M slp M2 slp2)"
| "slp_of_fa (Inverse a) M slp  =
   (let (M1, slp1) = slp_of_fa a M slp in slp_of_fa_un Inverse a M slp M1 slp1)"
| "slp_of_fa (Cos a) M slp  =
   (let (M1, slp1) = slp_of_fa a M slp in slp_of_fa_un Cos a M slp M1 slp1)"
| "slp_of_fa (Arctan a) M slp  =
   (let (M1, slp1) = slp_of_fa a M slp in slp_of_fa_un Arctan a M slp M1 slp1)"
| "slp_of_fa (Abs a) M slp  =
   (let (M1, slp1) = slp_of_fa a M slp in slp_of_fa_un Abs a M slp M1 slp1)"
| "slp_of_fa (Sqrt a) M slp  =
   (let (M1, slp1) = slp_of_fa a M slp in slp_of_fa_un Sqrt a M slp M1 slp1)"
| "slp_of_fa (Exp a) M slp  =
   (let (M1, slp1) = slp_of_fa a M slp in slp_of_fa_un Exp a M slp M1 slp1)"
| "slp_of_fa (Ln a) M slp  =
   (let (M1, slp1) = slp_of_fa a M slp in slp_of_fa_un Ln a M slp M1 slp1)"
| "slp_of_fa (Minus a) M slp  =
   (let (M1, slp1) = slp_of_fa a M slp in slp_of_fa_un Minus a M slp M1 slp1)"
| "slp_of_fa (Floor a) M slp  =
   (let (M1, slp1) = slp_of_fa a M slp in slp_of_fa_un Floor a M slp M1 slp1)"
| "slp_of_fa (Power a n) M slp  =
   (let (M1, slp1) = slp_of_fa a M slp in slp_of_fa_un (λa. Power a n) a M slp M1 slp1)"
| "slp_of_fa Pi M slp = slp_of_fa_cnst Pi Pi M slp"
| "slp_of_fa (Var v) M slp = slp_of_fa_cnst (Var v) (Var (v + length slp)) M slp"
| "slp_of_fa (Num n) M slp = slp_of_fa_cnst (Num n) (Num n) M slp"

lemma interpret_slp_snoc[simp]:
  "interpret_slp (slp @ [fa]) xs = interpret_floatarith fa (interpret_slp slp xs)#interpret_slp slp xs"
  by (induction slp arbitrary: fa xs) auto

lemma
  binop_slp_of_fa_induction_step:
  assumes
    Binop_IH1:
    "⋀M slp M' slp'. slp_of_fa fa1 M slp = (M', slp') ⟹
    (⋀f. f ∈ Mapping.keys M ⟹ subterms f ⊆ Mapping.keys M) ⟹
    (⋀f. f ∈ Mapping.keys M ⟹ the (Mapping.lookup M f) < length slp) ⟹
    (⋀f. f ∈ Mapping.keys M ⟹ interpret_slp slp xs ! slp_index_lookup slp M f = interpret_floatarith f xs) ⟹
    subterms fa1 ⊆ Mapping.keys M' ∧
    Mapping.keys M ⊆ Mapping.keys M' ∧
    (∀f∈Mapping.keys M'. subterms f ⊆ Mapping.keys M' ∧
      the (Mapping.lookup M' f) < length slp' ∧
      interpret_slp slp' xs ! slp_index_lookup slp' M' f = interpret_floatarith f xs)"
    and
    Binop_IH2:
    "⋀M slp M' slp'. slp_of_fa fa2 M slp = (M', slp') ⟹
    (⋀f. f ∈ Mapping.keys M ⟹ subterms f ⊆ Mapping.keys M) ⟹
    (⋀f. f ∈ Mapping.keys M ⟹ the (Mapping.lookup M f) < length slp) ⟹
    (⋀f. f ∈ Mapping.keys M ⟹ interpret_slp slp xs ! slp_index_lookup slp M f = interpret_floatarith f xs) ⟹
    subterms fa2 ⊆ Mapping.keys M' ∧
    Mapping.keys M ⊆ Mapping.keys M' ∧
    (∀f∈Mapping.keys M'. subterms f ⊆ Mapping.keys M' ∧
      the (Mapping.lookup M' f) < length slp' ∧
      interpret_slp slp' xs ! slp_index_lookup slp' M' f = interpret_floatarith f xs)"
    and Binop_prems:
    "(case slp_of_fa fa1 M slp of
      (M1, slp1) ⇒
       case slp_of_fa fa2 M1 slp1 of (x, xa) ⇒ slp_of_fa_bin Binop fa1 fa2 M slp x xa) = (M', slp')"
    "⋀f. f ∈ Mapping.keys M ⟹ subterms f ⊆ Mapping.keys M"
    "⋀f. f ∈ Mapping.keys M ⟹ the (Mapping.lookup M f) < length slp"
    "⋀f. f ∈ Mapping.keys M ⟹ interpret_slp slp xs ! slp_index_lookup slp M f = interpret_floatarith f xs"
  assumes subterms_Binop[simp]:
    "⋀a b. subterms (Binop a b) = insert (Binop a b) (subterms a ∪ subterms b)"
  assumes interpret_Binop[simp]:
    "⋀a b xs. interpret_floatarith (Binop a b) xs = binop (interpret_floatarith a xs) (interpret_floatarith b xs)"
shows "insert (Binop fa1 fa2) (subterms fa1 ∪ subterms fa2) ⊆ Mapping.keys M' ∧
    Mapping.keys M ⊆ Mapping.keys M' ∧
    (∀f∈Mapping.keys M'. subterms f ⊆ Mapping.keys M' ∧
       the (Mapping.lookup M' f) < length slp' ∧
       interpret_slp slp' xs ! slp_index_lookup slp' M' f  = interpret_floatarith f xs)"
proof -
  from Binop_prems
  obtain M1 slp1 M2 slp2 where *:
    "slp_of_fa fa1 M slp = (M1, slp1)"
    "slp_of_fa fa2 M1 slp1 = (M2, slp2)"
    "slp_of_fa_bin Binop fa1 fa2 M slp M2 slp2 = (M', slp')"
    by (auto split: prod.splits)
  from Binop_IH1[OF *(1) Binop_prems(2) Binop_prems(3) Binop_prems(4), simplified]
  have IH1:
    "f ∈ subterms fa1 ⟹ f ∈ Mapping.keys M1"
    "f ∈ Mapping.keys M ⟹ f ∈ Mapping.keys M1"
    "f ∈ Mapping.keys M1 ⟹ subterms f ⊆ Mapping.keys M1"
    "f ∈ Mapping.keys M1 ⟹ the (Mapping.lookup M1 f) < length slp1"
    "f ∈ Mapping.keys M1 ⟹ interpret_slp slp1 xs ! slp_index_lookup slp1 M1 f  = interpret_floatarith f xs"
    for f
    by (auto simp: subset_iff)
  from Binop_IH2[OF *(2) IH1(3) IH1(4) IH1(5)]
  have IH2:
    "f ∈ subterms fa2 ⟹ f ∈ Mapping.keys M2"
    "f ∈ Mapping.keys M1 ⟹ f ∈ Mapping.keys M2"
    "f ∈ Mapping.keys M2 ⟹ subterms f ⊆ Mapping.keys M2"
    "f ∈ Mapping.keys M2 ⟹ the (Mapping.lookup M2 f) < length slp2"
    "f ∈ Mapping.keys M2 ⟹ interpret_slp slp2 xs ! slp_index_lookup slp2 M2 f = interpret_floatarith f xs"
    for f
    by (auto simp: subset_iff)
  show ?thesis
  proof (cases "Mapping.lookup M (Binop fa1 fa2)")
    case None
    then have M': "M' = Mapping.update (Binop fa1 fa2) (length slp2) M2"
      and slp': "slp' = slp2 @ [Binop (Var (slp_index_lookup slp2 M2 fa1)) (Var (slp_index_lookup slp2 M2 fa2))]"
      using *
      by (auto simp: slp_of_fa_bin_def)
    have "Mapping.keys M ⊆ Mapping.keys M'"
      using IH1 IH2
      by (auto simp: M')
    have "Binop fa1 fa2 ∈ Mapping.keys M'"
      using M' by auto
    have M'_0: "Mapping.lookup M' (Binop fa1 fa2) = Some (length slp2)"
      by (auto simp: M' lookup_update)
    have fa1: "fa1 ∈ Mapping.keys M2" and fa2: "fa2 ∈ Mapping.keys M2"
      by (force intro: IH2 IH1)+
    have rew: "binop (interpret_slp slp2 xs ! slp_index_lookup slp2 M2 fa1) (interpret_slp slp2 xs ! slp_index_lookup slp2 M2 fa2) =
      binop (interpret_floatarith fa1 xs) (interpret_floatarith fa2 xs)"
      by (auto simp: IH2 fa1)
    show ?thesis
      apply (auto )
      subgoal by fact
      subgoal
        unfolding M'
        apply (simp add: )
        apply (rule disjI2)
        apply (rule IH2(2))
        apply (rule IH1) apply simp
        done
      subgoal
        unfolding M'
        apply (simp add: )
        apply (rule disjI2)
        apply (rule IH2)
        by simp
      subgoal
        unfolding M'
        apply simp
        apply (rule disjI2)
        apply (rule IH2(2))
        apply (rule IH1(2))
        by simp
      subgoal
        unfolding M'
        apply auto
        apply (simp add: IH1(1) IH2(2))
         apply (simp add: IH1(2) IH2(1))
        using IH2(3)
        by auto
      subgoal for f
        unfolding M' slp'
        apply simp
        apply (auto simp add: lookup_update' rew lookup_map_values slp_index_lookup_def slp_index_def)
        by (simp add: IH2(4) less_Suc_eq)
      subgoal for f
        unfolding M' slp'
        apply simp
        apply (subst rew)
        apply (auto simp add: fa1 lookup_update' rew lookup_map_values slp_index_lookup_def slp_index_def)
        apply (auto simp add: nth_Cons fa1 lookup_update' rew lookup_map_values slp_index_lookup_def slp_index_def
            split: nat.splits)
        using IH2(4) apply fastforce
        by (metis IH2(4) IH2(5) Suc_diff_Suc Suc_inject slp_index_def slp_index_lookup_def)
      done
  next
    case (Some C)
    then have M': "M' = Mapping.update (Binop fa1 fa2) (length slp) M"
      and slp': "slp' = slp @ [Var (slp_index slp C)]"
      and Binop_keys: "(Binop fa1 fa2) ∈ Mapping.keys M"
      using *
      by (auto simp: slp_of_fa_bin_def keys_dom_lookup)
    have "subterms (Binop fa1 fa2) ⊆ Mapping.keys M'"
      using Binop_keys assms(4)
      by (force simp: M')
    moreover
    have "Mapping.keys M ⊆ Mapping.keys M'"
      using Binop_keys
      by (auto simp add: M')
    moreover have "f∈Mapping.keys M' ⟹ interpret_slp slp' xs ! slp_index_lookup slp' M' f =
      interpret_floatarith f xs" for f
      apply (auto simp add: M' lookup_map_values lookup_update' slp' Binop_prems slp_index_def
          slp_index_lookup_def)
      apply (metis Binop_keys Some assms(6) interpret_Binop option.sel slp_index_def slp_index_lookup_def)
      apply (metis Binop_keys Some assms(6) interpret_Binop option.sel slp_index_def slp_index_lookup_def)
      apply (metis assms(6) slp_index_def slp_index_lookup_def)
      done
    moreover have "f∈Mapping.keys M' ⟹ subterms f ⊆ Mapping.keys M'" for f
      using Binop_keys Some assms(4,6)
      by (auto simp add: M' lookup_map_values)
    moreover have "f∈Mapping.keys M' ⟹ the (Mapping.lookup M' f) < length slp'" for f
      using Binop_keys Some assms(5,7) IH1 IH2
      by (auto simp add: M' lookup_map_values lookup_update' Binop_prems slp' less_SucI)
    ultimately
    show ?thesis
      by auto
  qed
qed

lemma
  unop_slp_of_fa_induction_step:
  assumes
    Unop_IH1:
    "⋀M slp M' slp'. slp_of_fa fa1 M slp = (M', slp') ⟹
    (⋀f. f ∈ Mapping.keys M ⟹ subterms f ⊆ Mapping.keys M) ⟹
    (⋀f. f ∈ Mapping.keys M ⟹ the (Mapping.lookup M f) < length slp) ⟹
    (⋀f. f ∈ Mapping.keys M ⟹ interpret_slp slp xs ! slp_index_lookup slp M f = interpret_floatarith f xs) ⟹
    subterms fa1 ⊆ Mapping.keys M' ∧
    Mapping.keys M ⊆ Mapping.keys M' ∧
    (∀f∈Mapping.keys M'. subterms f ⊆ Mapping.keys M' ∧
      the (Mapping.lookup M' f) < length slp' ∧
      interpret_slp slp' xs ! slp_index_lookup slp' M' f = interpret_floatarith f xs)"
    and Unop_prems:
    "(case slp_of_fa fa1 M slp of (M1, slp1) ⇒ slp_of_fa_un Unop fa1 M slp M1 slp1) = (M', slp')"
    "⋀f. f ∈ Mapping.keys M ⟹ subterms f ⊆ Mapping.keys M"
    "⋀f. f ∈ Mapping.keys M ⟹ the (Mapping.lookup M f) < length slp"
    "⋀f. f ∈ Mapping.keys M ⟹ interpret_slp slp xs ! slp_index_lookup slp M f = interpret_floatarith f xs"
  assumes subterms_Unop[simp]:
    "⋀a b. subterms (Unop a) = insert (Unop a) (subterms a)"
  assumes interpret_Unop[simp]:
    "⋀a b xs. interpret_floatarith (Unop a) xs = unop (interpret_floatarith a xs)"
shows "insert (Unop fa1) (subterms fa1) ⊆ Mapping.keys M' ∧
    Mapping.keys M ⊆ Mapping.keys M' ∧
    (∀f∈Mapping.keys M'. subterms f ⊆ Mapping.keys M' ∧
      the (Mapping.lookup M' f) < length slp'  ∧
      interpret_slp slp' xs ! slp_index_lookup slp' M' f = interpret_floatarith f xs)"
proof -
  from Unop_prems
  obtain M1 slp1 where *:
    "slp_of_fa fa1 M slp = (M1, slp1)"
    "slp_of_fa_un Unop fa1 M slp M1 slp1 = (M', slp')"
    by (auto split: prod.splits)
  from Unop_IH1[OF *(1) Unop_prems(2) Unop_prems(3) Unop_prems(4), simplified]
  have IH1:
    "f ∈ subterms fa1 ⟹ f ∈ Mapping.keys M1"
    "f ∈ Mapping.keys M ⟹ f ∈ Mapping.keys M1"
    "f ∈ Mapping.keys M1 ⟹ subterms f ⊆ Mapping.keys M1"
    "f ∈ Mapping.keys M1 ⟹ the (Mapping.lookup M1 f) < length slp1"
    "f ∈ Mapping.keys M1 ⟹ interpret_slp slp1 xs ! slp_index_lookup slp1 M1 f = interpret_floatarith f xs"
    for f
    by (auto simp: subset_iff)
  show ?thesis
  proof (cases "Mapping.lookup M (Unop fa1)")
    case None
    then have M': "M' = Mapping.update (Unop fa1) (length slp1) M1 "
      and slp': "slp' = slp1 @ [Unop (Var (slp_index_lookup slp1 M1 fa1))]"
      using *
      by (auto simp: slp_of_fa_un_def)
    have "Mapping.keys M ⊆ Mapping.keys M'"
      using IH1
      by (auto simp: M')
    have "Unop fa1 ∈ Mapping.keys M'"
      using M' by auto
    have fa1: "fa1 ∈ Mapping.keys M1"
      by (force intro: IH1)+
    have rew: "interpret_slp slp1 xs ! slp_index_lookup slp1 M1 fa1  = interpret_floatarith fa1 xs"
      by (auto simp: IH1 fa1)
    show ?thesis
      apply (auto )
      subgoal by fact
      subgoal
        unfolding M'
        apply (simp add: )
        apply (rule disjI2)
        apply (rule IH1) apply simp
        done
      subgoal
        unfolding M'
        apply (simp add: )
        apply (rule disjI2)
        by (rule IH1) simp
      subgoal
        using IH1(3) M' ‹⋀x. x ∈ subterms fa1 ⟹ x ∈ Mapping.keys M'› by fastforce
      subgoal for f
        unfolding M' slp'
        apply simp
        apply (auto simp add: lookup_update' rew lookup_map_values)
        by (simp add: IH1(4) less_SucI)
      subgoal for f
        unfolding M' slp'
        apply simp
        apply (subst rew)
        apply (auto simp add: fa1 lookup_update' rew lookup_map_values slp_index_lookup_def slp_index_def)
        apply (auto simp add: nth_Cons fa1 lookup_update' rew lookup_map_values slp_index_lookup_def slp_index_def
            split: nat.splits)
        using IH1(4) apply fastforce
        by (metis IH1(4) IH1(5) Suc_diff_Suc Suc_inject slp_index_def slp_index_lookup_def)
      done
  next
    case (Some C)
    then have M': "M' = Mapping.update (Unop fa1) (length slp) M"
      and slp': "slp' = slp @ [Var (slp_index slp C)]"
      and Unop_keys: "(Unop fa1) ∈ Mapping.keys M"
      using *
      by (auto simp: slp_of_fa_un_def keys_dom_lookup)
    have "subterms (Unop fa1) ⊆ Mapping.keys M'"
      using Unop_keys assms(3)
      by (force simp: M')
    moreover
    have "Mapping.keys M ⊆ Mapping.keys M'"
      using Unop_keys assms(5)
      by (force simp: M' IH1)
    moreover have "f∈Mapping.keys M' ⟹ interpret_slp slp' xs ! slp_index_lookup slp' M' f  =
        interpret_floatarith f xs" for f
      apply (auto simp add: M' lookup_map_values lookup_update' slp' Unop_prems slp_index_def slp_index_lookup_def)
      apply (metis Unop_keys Some assms(5) interpret_Unop option.sel slp_index_def slp_index_lookup_def)
      apply (metis Unop_keys Some assms(5) interpret_Unop option.sel slp_index_def slp_index_lookup_def)
      apply (metis assms(5) slp_index_def slp_index_lookup_def)
      done
    moreover have "f∈Mapping.keys M' ⟹ subterms f ⊆ Mapping.keys M'" for f
      using Unop_keys Some assms(3,5)
      by (auto simp add: M' lookup_map_values)
    moreover have "f∈Mapping.keys M' ⟹ the (Mapping.lookup M' f) < length slp'" for f
      by (auto simp add: M' lookup_map_values lookup_update' slp' Unop_prems IH1 less_SucI)
    ultimately
    show ?thesis
      by auto
  qed
qed

lemma
  cnst_slp_of_fa_induction_step:
  assumes *:
    "slp_of_fa_cnst Unop Unop' M slp = (M', slp')"
    "⋀f. f ∈ Mapping.keys M ⟹ subterms f ⊆ Mapping.keys M"
    "⋀f. f ∈ Mapping.keys M ⟹ the (Mapping.lookup M f) < length slp"
    "⋀f. f ∈ Mapping.keys M ⟹ interpret_slp slp xs ! slp_index_lookup slp M f = interpret_floatarith f xs"
  assumes subterms_Unop[simp]:
    "⋀a b. subterms (Unop) = {Unop}"
  assumes interpret_Unop[simp]:
    "interpret_floatarith Unop xs = unop xs"
    "interpret_floatarith Unop' (interpret_slp slp xs) = unop xs"
  assumes ui: "unop (interpret_slp slp xs) = unop xs"
  shows "{Unop} ⊆ Mapping.keys M' ∧
    Mapping.keys M ⊆ Mapping.keys M' ∧
    (∀f∈Mapping.keys M'. subterms f ⊆ Mapping.keys M' ∧
      the (Mapping.lookup M' f) < length slp' ∧
      interpret_slp slp' xs ! slp_index_lookup slp' M' f = interpret_floatarith f xs)"
proof -
  show ?thesis
  proof (cases "Mapping.lookup M Unop")
    case None
    then have M': "M' = Mapping.update Unop (length slp) M"
      and slp': "slp' = slp @ [Unop']"
      using *
      by (auto simp: slp_of_fa_cnst_def)
    have "Mapping.keys M ⊆ Mapping.keys M'"
      by (auto simp: M')
    have "Unop ∈ Mapping.keys M'"
      using M' by auto
    show ?thesis
      apply (auto )
      subgoal by fact
      subgoal
        unfolding M'
        apply (simp add: )
        done
      subgoal
        unfolding M'
        apply (simp add: )
        using assms by auto
      subgoal
        unfolding M' slp'
        apply simp
        apply (auto simp add: lookup_update' ui lookup_map_values)
        using interpret_Unop apply auto[1]
        by (simp add: assms(3) less_Suc_eq)
      subgoal for f
        unfolding M' slp'
        apply simp
        apply (auto simp add: lookup_update' ui lookup_map_values slp_index_lookup_def slp_index_def)
        using interpret_Unop apply auto[1]
          apply (auto simp: nth_Cons split: nat.splits)
        using assms(3) leD apply blast
        by (metis Suc_diff_Suc Suc_inject assms(3) assms(4) slp_index_def slp_index_lookup_def)
      done
  next
    case (Some C)
    then have M': "M' = Mapping.update Unop (length slp) M"
      and slp': "slp' = slp @ [Var (slp_index slp C)]"
      and Unop_keys: "(Unop) ∈ Mapping.keys M"
      using *
      by (auto simp: slp_of_fa_cnst_def keys_dom_lookup)
    have "subterms (Unop) ⊆ Mapping.keys M'"
      using Unop_keys
      by (fastforce simp: M')
    moreover
    have "Mapping.keys M ⊆ Mapping.keys M'"
      using Unop_keys assms(5)
      by (force simp: M')
    moreover have "f∈Mapping.keys M' ⟹ interpret_slp slp' xs ! slp_index_lookup slp' M' f  = interpret_floatarith f xs" for f
      apply (auto simp add: M' lookup_map_values lookup_update' slp' slp_index_lookup_def slp_index_def)
      apply (metis Some Unop_keys assms(4) interpret_Unop option.sel slp_index_def slp_index_lookup_def)
      apply (metis Some Unop_keys assms(4) interpret_Unop option.sel slp_index_def slp_index_lookup_def)
      by (metis Suc_diff_Suc assms(3) assms(4) nth_Cons_Suc slp_index_def slp_index_lookup_def)
    moreover have "f∈Mapping.keys M' ⟹ subterms f ⊆ Mapping.keys M'" for f
      using assms by (auto simp add: M' lookup_map_values lookup_update' slp')
    moreover have "f∈Mapping.keys M' ⟹ the (Mapping.lookup M' f) < length slp'" for f
      using assms
      by (auto simp add: M' lookup_map_values lookup_update' slp' less_SucI)
    ultimately
    show ?thesis
      by auto
  qed
qed

lemma interpret_slp_nth:
  "n ≥ length slp ⟹ interpret_slp slp xs ! n = xs ! (n - length slp)"
  by (induction slp arbitrary: xs n) auto

theorem
  interpret_slp_of_fa:
  assumes "slp_of_fa fa M slp = (M', slp')"
  assumes "⋀f. f ∈ Mapping.keys M ⟹ subterms f ⊆ Mapping.keys M"
  assumes "⋀f. f ∈ Mapping.keys M ⟹ (the (Mapping.lookup M f)) < length slp"
  assumes "⋀f. f ∈ Mapping.keys M ⟹ interpret_slp slp xs ! slp_index_lookup slp M f = interpret_floatarith f xs"
  shows "subterms fa ⊆ Mapping.keys M' ∧ Mapping.keys M ⊆ Mapping.keys M' ∧
    (∀f ∈ Mapping.keys M'.
      subterms f ⊆ Mapping.keys M' ∧
      the (Mapping.lookup M' f) < length slp' ∧
      (interpret_slp slp' xs ! slp_index_lookup slp' M' f = interpret_floatarith f xs))"
  using assms
proof (induction fa arbitrary: M' slp' M slp)
  case *: (Add fa1 fa2)
  show ?case
    unfolding subterms.simps
    by (rule binop_slp_of_fa_induction_step[OF
          *[unfolded subterms.simps slp_of_fa.simps Let_def]]) auto
next
  case *: (Mult fa1 fa2)
  show ?case
    unfolding subterms.simps
    by (rule binop_slp_of_fa_induction_step[OF
          *[unfolded subterms.simps slp_of_fa.simps Let_def]]) auto
next
  case *: (Min fa1 fa2)
  show ?case
    unfolding subterms.simps
    by (rule binop_slp_of_fa_induction_step[OF
          *[unfolded subterms.simps slp_of_fa.simps Let_def]]) auto
next
  case *: (Max fa1 fa2)
  show ?case
    unfolding subterms.simps
    by (rule binop_slp_of_fa_induction_step[OF
          *[unfolded subterms.simps slp_of_fa.simps Let_def]]) auto
next
  case *: (Powr fa1 fa2)
  show ?case
    unfolding subterms.simps
    by (rule binop_slp_of_fa_induction_step[OF
          *[unfolded subterms.simps slp_of_fa.simps Let_def]]) auto
next
  case *: (Minus fa1)
  show ?case
    unfolding subterms.simps
    by (rule unop_slp_of_fa_induction_step[OF
          *[unfolded subterms.simps slp_of_fa.simps Let_def]]) auto
next
  case *: (Inverse fa1)
  show ?case
    unfolding subterms.simps
    by (rule unop_slp_of_fa_induction_step[OF
          *[unfolded subterms.simps slp_of_fa.simps Let_def]]) auto
next
  case *: (Arctan fa1)
  show ?case
    unfolding subterms.simps
    by (rule unop_slp_of_fa_induction_step[OF
          *[unfolded subterms.simps slp_of_fa.simps Let_def]]) auto
next
  case *: (Floor fa1)
  show ?case
    unfolding subterms.simps
    by (rule unop_slp_of_fa_induction_step[OF
          *[unfolded subterms.simps slp_of_fa.simps Let_def]]) auto
next
  case *: (Cos fa1)
  show ?case
    unfolding subterms.simps
    by (rule unop_slp_of_fa_induction_step[OF
          *[unfolded subterms.simps slp_of_fa.simps Let_def]]) auto
next
  case *: (Ln fa1)
  show ?case
    unfolding subterms.simps
    by (rule unop_slp_of_fa_induction_step[OF
          *[unfolded subterms.simps slp_of_fa.simps Let_def]]) auto
next
  case *: (Power fa1)
  show ?case
    unfolding subterms.simps
    by (rule unop_slp_of_fa_induction_step[OF
          *[unfolded subterms.simps slp_of_fa.simps Let_def]]) auto
next
  case *: (Abs fa1)
  show ?case
    unfolding subterms.simps
    by (rule unop_slp_of_fa_induction_step[OF
          *[unfolded subterms.simps slp_of_fa.simps Let_def]]) auto
next
  case *: (Sqrt fa1)
  show ?case
    unfolding subterms.simps
    by (rule unop_slp_of_fa_induction_step[OF
          *[unfolded subterms.simps slp_of_fa.simps Let_def]]) auto
next
  case *: (Exp fa1)
  show ?case
    unfolding subterms.simps
    by (rule unop_slp_of_fa_induction_step[OF
          *[unfolded subterms.simps slp_of_fa.simps Let_def]]) auto
next
  case *: Pi
  show ?case
    unfolding subterms.simps
    by (rule cnst_slp_of_fa_induction_step[OF
          *[unfolded subterms.simps slp_of_fa.simps Let_def]]) auto
next
  case *: Num
  show ?case
    unfolding subterms.simps
    by (rule cnst_slp_of_fa_induction_step[OF
          *[unfolded subterms.simps slp_of_fa.simps Let_def]]) auto
next
  case *: (Var n)
  show ?case
    unfolding subterms.simps
    by (rule cnst_slp_of_fa_induction_step[OF
          *[unfolded subterms.simps slp_of_fa.simps Let_def]])
       (auto simp: interpret_slp_nth)
qed

primrec slp_of_fas' where
  "slp_of_fas' [] M slp = (M, slp)"
| "slp_of_fas' (fa#fas) M slp = (let (M, slp) = slp_of_fa fa M slp in slp_of_fas' fas M slp)"

theorem
  interpret_slp_of_fas':
  assumes "slp_of_fas' fas M slp = (M', slp')"
  assumes "⋀f. f ∈ Mapping.keys M ⟹ subterms f ⊆ Mapping.keys M"
  assumes "⋀f. f ∈ Mapping.keys M ⟹ the (Mapping.lookup M f) < length slp"
  assumes "⋀f. f ∈ Mapping.keys M ⟹ interpret_slp slp xs ! slp_index_lookup slp M f = interpret_floatarith f xs"
  shows "⋃(subterms ` set fas) ⊆ Mapping.keys M' ∧ Mapping.keys M ⊆ Mapping.keys M' ∧
    (∀f ∈ Mapping.keys M'. subterms f ⊆ Mapping.keys M' ∧
      (the (Mapping.lookup M' f) < length slp') ∧
      (interpret_slp slp' xs ! slp_index_lookup slp' M' f = interpret_floatarith f xs))"
  using assms
proof (induction fas arbitrary: M slp)
  case Nil then show ?case
    by auto
next
  case (Cons fa fas)
  from ‹slp_of_fas' (fa # fas) M slp = (M', slp')›
  obtain M1 slp1 where
    fa: "slp_of_fa fa M slp = (M1, slp1)"
    and fas: "slp_of_fas' fas M1 slp1 = (M', slp')"
    by (auto split: prod.splits)
  have "subterms fa ⊆ Mapping.keys M1 ∧
    Mapping.keys M ⊆ Mapping.keys M1 ∧
    (∀f∈Mapping.keys M1. subterms f ⊆ Mapping.keys M1 ∧
    the (Mapping.lookup M1 f) < length slp1 ∧
    interpret_slp slp1 xs ! slp_index_lookup slp1 M1 f= interpret_floatarith f xs)"
    apply (rule interpret_slp_of_fa[OF fa, of xs])
    using Cons.prems
    by (auto split: prod.splits simp: trans_less_add2)
  moreover
  then have "(⋃a∈set fas. subterms a) ⊆ Mapping.keys M' ∧
    Mapping.keys M1 ⊆ Mapping.keys M' ∧
    (∀f∈Mapping.keys M'. subterms f ⊆ Mapping.keys M' ∧
    the (Mapping.lookup M' f) < length slp' ∧
    interpret_slp slp' xs ! slp_index_lookup slp' M' f = interpret_floatarith f xs)"
    using Cons.prems
    by (intro Cons.IH[OF fas])
       (auto split: prod.splits simp: trans_less_add2)
  ultimately
  show ?case
    by auto
qed

definition "slp_of_fas fas =
  (let
    (M, slp) = slp_of_fas' fas Mapping.empty [];
    fasi = map (the o Mapping.lookup M) fas;
    fasi' = map (λ(a, b). Var (length slp + a - Suc b)) (zip [0..<length fasi] (rev fasi))
  in slp @ fasi')"

lemma length_interpret_slp[simp]:
  "length (interpret_slp slp xs) = length slp + length xs"
  by (induct slp arbitrary: xs) auto

lemma length_interpret_floatariths[simp]:
  "length (interpret_floatariths slp xs) = length slp"
  by (induct slp arbitrary: xs) auto

lemma interpret_slp_append[simp]:
  "interpret_slp (slp1 @ slp2) xs =
    interpret_slp slp2 (interpret_slp slp1 xs)"
  by (induction slp1 arbitrary: slp2 xs) auto

lemma "interpret_slp (map Var [a + 0, b + 1, c + 2, d + 3]) xs =
  (rev (map (λ(i, e). xs ! (e - i)) (zip [0..<4] [a + 0, b + 1, c + 2, d + 3])))@xs"
  by (auto simp: numeral_eq_Suc)

lemma aC_eq_aa: "xs @ y # zs = (xs @ [y]) @ zs"
  by simp

lemma
  interpret_slp_map_Var:
  assumes "⋀i. i < length is ⟹ is ! i ≥ i"
  assumes "⋀i. i < length is ⟹ (is ! i - i) < length xs"
  shows "interpret_slp (map Var is) xs =
    (rev (map (λ(i, e). xs ! (e - i)) (zip [0..<length is] is)))
    @
    xs"
  using assms
proof (induction "is" arbitrary: xs)
  case Nil
  then show ?case by simp
next
  case (Cons a "is")
  show ?case
    unfolding interpret_slp.simps list.map
    apply (subst Cons.IH)
    subgoal using Cons.prems by force
    subgoal using Cons.prems by force
    subgoal
      apply (subst aC_eq_aa)
      apply (subst rev.simps(2)[symmetric])
      apply (rule arg_cong[where f="λa. a @ xs"])
      apply (rule arg_cong[where f="rev"])
      unfolding interpret_floatarith.simps
      apply auto
      apply (rule nth_equalityI)
       apply force
      apply auto
      using Cons.prems
      apply (auto simp: nth_append nth_Cons split: nat.splits)
      subgoal
        by (metis Suc_leI le_imp_less_Suc not_le old.nat.simps(5))
      subgoal
        by (simp add: minus_nat.simps(2))
      subgoal
        by (metis Suc_lessI minus_nat.simps(2) old.nat.simps(5))
      done
    done
qed

theorem slp_of_fas:
  "take (length fas) (interpret_slp (slp_of_fas fas) xs) = interpret_floatariths fas xs"
proof -
  obtain M slp where Mslp:
    "slp_of_fas' fas Mapping.empty [] = (M, slp)"
    using old.prod.exhaust by blast
  have M: "⋃(subterms ` (set fas)) ⊆ Mapping.keys M ∧
    Mapping.keys (Mapping.empty::(floatarith, nat) mapping) ⊆ Mapping.keys M ∧
    (∀f∈Mapping.keys M.
        subterms f ⊆ Mapping.keys M ∧
        the (Mapping.lookup M f) < length slp ∧
        interpret_slp slp xs ! slp_index_lookup slp M f =
        interpret_floatarith f xs)"
    by (rule interpret_slp_of_fas'[OF Mslp]) auto
  have map_eq:
    "map (λ(a, b). Var (length slp + a - Suc b)) (zip [0..<length fas] (rev (map ((λx. the o (Mapping.lookup x)) M) fas)))
    = map Var (map (λ(a, b). (length slp + a - Suc b)) (zip [0..<length fas] (rev (map (the ∘ Mapping.lookup M) fas))))"
    unfolding split_beta'
    by (simp add: split_beta')
  have "take (length fas)
     (interpret_slp
       (slp @
        map (λ(a, b). Var (length slp + a - Suc b)) (zip [0..<length fas] (rev (map (((λx. the o (Mapping.lookup x))) M) fas))))
       xs) =
    interpret_floatariths fas xs"
    apply simp
    unfolding map_eq
    apply (subst interpret_slp_map_Var)
      apply (auto simp: rev_nth)
    subgoal premises prems for i
    proof -
      from prems have " (length fas - Suc i) < length fas" using prems by auto
      then have "fas ! (length fas - Suc i) ∈ set fas"
        by simp
      also have "… ⊆ Mapping.keys M"
        using M by force
      finally have "fas ! (length fas - Suc i) ∈ Mapping.keys M" .
      with M
      show ?thesis
        by auto
    qed
    subgoal premises prems for i
    proof -
      from prems have " (length fas - Suc i) < length fas" using prems by auto
      then have "fas ! (length fas - Suc i) ∈ set fas"
        by simp
      also have "… ⊆ Mapping.keys M"
        using M by force
      finally have "fas ! (length fas - Suc i) ∈ Mapping.keys M" .
      with M
      show ?thesis
        by auto
    qed
    subgoal
      apply (rule nth_equalityI, auto)
      subgoal premises prems for i
      proof -
        from prems have "fas ! i ∈ set fas"
          by simp
        also have "… ⊆ Mapping.keys M"
          using M by force
        finally have "fas ! i ∈ Mapping.keys M" .
        from M[THEN conjunct2, THEN conjunct2, rule_format, OF this]
        show ?thesis
          using prems
          by (auto simp: rev_nth interpret_floatariths_nth slp_index_lookup_def slp_index_def)
      qed
      done
    done
  then show ?thesis
    by (auto simp: slp_of_fas_def Let_def Mslp)
qed


subsection ‹better code equations for construction of large programs›

definition "slp_indexl slpl i = slpl - Suc i"
definition "slp_indexl_lookup vsl M a = slp_indexl vsl (the (Mapping.lookup M a))"

definition
  "slp_of_fa_rev_bin Binop a b M slp slpl M2 slp2 slpl2 =
    (case Mapping.lookup M (Binop a b) of
        Some i ⇒ (Mapping.update (Binop a b) (slpl) M, Var (slp_indexl slpl i)#slp, Suc slpl)
      | None ⇒ (Mapping.update (Binop a b) (slpl2) M2,
                Binop (Var (slp_indexl_lookup slpl2 M2 a)) (Var (slp_indexl_lookup slpl2 M2 b))#slp2,
                  Suc slpl2))"

definition
  "slp_of_fa_rev_un Unop a M slp slpl M1 slp1 slpl1 =
    (case Mapping.lookup M (Unop a) of
        Some i ⇒ (Mapping.update (Unop a) (slpl) M, Var (slp_indexl slpl i)#slp, Suc slpl)
      | None ⇒ (Mapping.update (Unop a) (slpl1) M1,
                  Unop (Var (slp_indexl_lookup slpl1 M1 a))#slp1, Suc slpl1))"

definition
  "slp_of_fa_rev_cnst Const Const' M vs vsl =
    (Mapping.update Const vsl M,
      (case Mapping.lookup M Const of Some i ⇒ Var (slp_indexl vsl i) | None ⇒ Const')#vs, Suc vsl)"

fun slp_of_fa_rev :: "floatarith ⇒ (floatarith, nat) mapping ⇒ floatarith list ⇒ nat ⇒
  ((floatarith, nat) mapping × floatarith list × nat)" where
"slp_of_fa_rev (Add a b) M slp slpl =
    (let (M1, slp1, slpl1) = slp_of_fa_rev a M slp slpl; (M2, slp2, slpl2) = slp_of_fa_rev b M1 slp1 slpl1 in
      slp_of_fa_rev_bin Add a b M slp slpl M2 slp2 slpl2)"
| "slp_of_fa_rev (Mult a b) M slp slpl =
    (let (M1, slp1, slpl1) = slp_of_fa_rev a M slp slpl; (M2, slp2, slpl2) = slp_of_fa_rev b M1 slp1 slpl1 in
      slp_of_fa_rev_bin Mult a b M slp slpl M2 slp2 slpl2)"
| "slp_of_fa_rev (Min a b) M slp slpl =
    (let (M1, slp1, slpl1) = slp_of_fa_rev a M slp slpl; (M2, slp2, slpl2) = slp_of_fa_rev b M1 slp1 slpl1 in
      slp_of_fa_rev_bin Min a b M slp slpl M2 slp2 slpl2)"
| "slp_of_fa_rev (Max a b) M slp slpl =
    (let (M1, slp1, slpl1) = slp_of_fa_rev a M slp slpl; (M2, slp2, slpl2) = slp_of_fa_rev b M1 slp1 slpl1 in
      slp_of_fa_rev_bin Max a b M slp slpl M2 slp2 slpl2)"
| "slp_of_fa_rev (Powr a b) M slp slpl =
    (let (M1, slp1, slpl1) = slp_of_fa_rev a M slp slpl; (M2, slp2, slpl2) = slp_of_fa_rev b M1 slp1 slpl1 in
      slp_of_fa_rev_bin Powr a b M slp slpl M2 slp2 slpl2)"
| "slp_of_fa_rev (Inverse a) M slp slpl =
   (let (M1, slp1, slpl1) = slp_of_fa_rev a M slp slpl in slp_of_fa_rev_un Inverse a M slp slpl M1 slp1 slpl1)"
| "slp_of_fa_rev (Cos a) M slp slpl =
   (let (M1, slp1, slpl1) = slp_of_fa_rev a M slp slpl in slp_of_fa_rev_un Cos a M slp slpl M1 slp1 slpl1)"
| "slp_of_fa_rev (Arctan a) M slp slpl =
   (let (M1, slp1, slpl1) = slp_of_fa_rev a M slp slpl in slp_of_fa_rev_un Arctan a M slp slpl M1 slp1 slpl1)"
| "slp_of_fa_rev (Abs a) M slp slpl =
   (let (M1, slp1, slpl1) = slp_of_fa_rev a M slp slpl in slp_of_fa_rev_un Abs a M slp slpl M1 slp1 slpl1)"
| "slp_of_fa_rev (Sqrt a) M slp slpl =
   (let (M1, slp1, slpl1) = slp_of_fa_rev a M slp slpl in slp_of_fa_rev_un Sqrt a M slp slpl M1 slp1 slpl1)"
| "slp_of_fa_rev (Exp a) M slp slpl =
   (let (M1, slp1, slpl1) = slp_of_fa_rev a M slp slpl in slp_of_fa_rev_un Exp a M slp slpl M1 slp1 slpl1)"
| "slp_of_fa_rev (Ln a) M slp slpl =
   (let (M1, slp1, slpl1) = slp_of_fa_rev a M slp slpl in slp_of_fa_rev_un Ln a M slp slpl M1 slp1 slpl1)"
| "slp_of_fa_rev (Minus a) M slp slpl =
   (let (M1, slp1, slpl1) = slp_of_fa_rev a M slp slpl in slp_of_fa_rev_un Minus a M slp slpl M1 slp1 slpl1)"
| "slp_of_fa_rev (Floor a) M slp slpl =
   (let (M1, slp1, slpl1) = slp_of_fa_rev a M slp slpl in slp_of_fa_rev_un Floor a M slp slpl M1 slp1 slpl1)"
| "slp_of_fa_rev (Power a n) M slp slpl =
   (let (M1, slp1, slpl1) = slp_of_fa_rev a M slp slpl in slp_of_fa_rev_un (λa. Power a n) a M slp slpl M1 slp1 slpl1)"
| "slp_of_fa_rev Pi M slp slpl = slp_of_fa_rev_cnst Pi Pi M slp slpl"
| "slp_of_fa_rev (Var v) M slp slpl = slp_of_fa_rev_cnst (Var v) (Var (v + slpl)) M slp slpl"
| "slp_of_fa_rev (Num n) M slp slpl = slp_of_fa_rev_cnst (Num n) (Num n) M slp slpl"

lemma slp_indexl_length[simp]: "slp_indexl (length xs) i = slp_index xs i"
  by (auto simp: slp_index_def slp_indexl_def)

lemma slp_indexl_lookup_length[simp]: "slp_indexl_lookup (length xs) i = slp_index_lookup xs i"
  by (auto simp: slp_index_lookup_def slp_indexl_lookup_def)

lemma slp_index_rev[simp]: "slp_index (rev xs) i = slp_index xs i"
  by (auto simp: slp_index_def slp_indexl_def)

lemma slp_index_lookup_rev[simp]: "slp_index_lookup (rev xs) i = slp_index_lookup xs i"
  by (auto simp: slp_index_lookup_def slp_indexl_lookup_def)

lemma slp_of_fa_bin_slp_of_fa_rev_bin:
  "slp_of_fa_rev_bin Binop a b M slp (length slp) M2 slp2 (length slp2) =
   (let (M, slp') = slp_of_fa_bin Binop a b M (rev slp) M2 (rev slp2) in (M, rev slp', length slp'))"
  by (auto simp: slp_of_fa_rev_bin_def slp_of_fa_bin_def
      split: prod.splits option.splits)

lemma slp_of_fa_un_slp_of_fa_rev_un:
  "slp_of_fa_rev_un Binop a M slp (length slp) M2 slp2 (length slp2) =
   (let (M, slp') = slp_of_fa_un Binop a M (rev slp) M2 (rev slp2) in (M, rev slp', length slp'))"
  by (auto simp: slp_of_fa_rev_un_def slp_of_fa_un_def split: prod.splits option.splits)

lemma slp_of_fa_cnst_slp_of_fa_rev_cnst:
  "slp_of_fa_rev_cnst Cnst Cnst' M slp (length slp) =
   (let (M, slp') = slp_of_fa_cnst Cnst Cnst' M (rev slp) in (M, rev slp', length slp'))"
  by (auto simp: slp_of_fa_rev_cnst_def slp_of_fa_cnst_def
      split: prod.splits option.splits)

lemma slp_of_fa_rev:
  "slp_of_fa_rev fa M slp (length slp) = (let (M, slp') = slp_of_fa fa M (rev slp) in (M, rev slp', length slp'))"
proof (induction fa arbitrary: M slp)
  case (Add fa1 fa2)
  then show ?case
    by (auto split: prod.splits simp: Let_def
      slp_of_fa_cnst_slp_of_fa_rev_cnst slp_of_fa_bin_slp_of_fa_rev_bin slp_of_fa_un_slp_of_fa_rev_un)
      (metis (no_types, lifting) Pair_inject length_rev prod.simps(2) rev_rev_ident slp_of_fa_bin_slp_of_fa_rev_bin)
next
  case (Minus fa)
  then show ?case
    by (auto split: prod.splits simp: Let_def
      slp_of_fa_cnst_slp_of_fa_rev_cnst slp_of_fa_bin_slp_of_fa_rev_bin slp_of_fa_un_slp_of_fa_rev_un)
    (metis (mono_tags, lifting) length_rev prod.simps(2) rev_swap slp_of_fa_un_slp_of_fa_rev_un)
next
  case (Mult fa1 fa2)
  then show ?case
    by (auto split: prod.splits simp: Let_def
      slp_of_fa_cnst_slp_of_fa_rev_cnst slp_of_fa_bin_slp_of_fa_rev_bin slp_of_fa_un_slp_of_fa_rev_un)
      (metis (no_types, lifting) Pair_inject length_rev prod.simps(2) rev_rev_ident slp_of_fa_bin_slp_of_fa_rev_bin)
next
  case (Inverse fa)
  then show ?case
    by (auto split: prod.splits simp: Let_def
      slp_of_fa_cnst_slp_of_fa_rev_cnst slp_of_fa_bin_slp_of_fa_rev_bin slp_of_fa_un_slp_of_fa_rev_un)
    (metis (mono_tags, lifting) length_rev prod.simps(2) rev_swap slp_of_fa_un_slp_of_fa_rev_un)
next
  case (Cos fa)
  then show ?case
    by (auto split: prod.splits simp: Let_def
      slp_of_fa_cnst_slp_of_fa_rev_cnst slp_of_fa_bin_slp_of_fa_rev_bin slp_of_fa_un_slp_of_fa_rev_un)
    (metis (mono_tags, lifting) length_rev prod.simps(2) rev_swap slp_of_fa_un_slp_of_fa_rev_un)
next
  case (Arctan fa)
  then show ?case
    by (auto split: prod.splits simp: Let_def
      slp_of_fa_cnst_slp_of_fa_rev_cnst slp_of_fa_bin_slp_of_fa_rev_bin slp_of_fa_un_slp_of_fa_rev_un)
    (metis (mono_tags, lifting) length_rev prod.simps(2) rev_swap slp_of_fa_un_slp_of_fa_rev_un)
next
  case (Abs fa)
  then show ?case
    by (auto split: prod.splits simp: Let_def
      slp_of_fa_cnst_slp_of_fa_rev_cnst slp_of_fa_bin_slp_of_fa_rev_bin slp_of_fa_un_slp_of_fa_rev_un)
    (metis (mono_tags, lifting) length_rev prod.simps(2) rev_swap slp_of_fa_un_slp_of_fa_rev_un)
next
  case (Max fa1 fa2)
  then show ?case
    by (auto split: prod.splits simp: Let_def
      slp_of_fa_cnst_slp_of_fa_rev_cnst slp_of_fa_bin_slp_of_fa_rev_bin slp_of_fa_un_slp_of_fa_rev_un)
      (metis (no_types, lifting) Pair_inject length_rev prod.simps(2) rev_rev_ident slp_of_fa_bin_slp_of_fa_rev_bin)
next
  case (Min fa1 fa2)
  then show ?case
    by (auto split: prod.splits simp: Let_def
      slp_of_fa_cnst_slp_of_fa_rev_cnst slp_of_fa_bin_slp_of_fa_rev_bin slp_of_fa_un_slp_of_fa_rev_un)
      (metis (no_types, lifting) Pair_inject length_rev prod.simps(2) rev_rev_ident slp_of_fa_bin_slp_of_fa_rev_bin)
next
  case Pi
  then show ?case
    by (auto split: prod.splits simp: Let_def
      slp_of_fa_cnst_slp_of_fa_rev_cnst slp_of_fa_bin_slp_of_fa_rev_bin slp_of_fa_un_slp_of_fa_rev_un)
next
  case (Sqrt fa)
  then show ?case
    by (auto split: prod.splits simp: Let_def
      slp_of_fa_cnst_slp_of_fa_rev_cnst slp_of_fa_bin_slp_of_fa_rev_bin slp_of_fa_un_slp_of_fa_rev_un)
    (metis (mono_tags, lifting) length_rev prod.simps(2) rev_swap slp_of_fa_un_slp_of_fa_rev_un)
next
  case (Exp fa)
  then show ?case
    by (auto split: prod.splits simp: Let_def
      slp_of_fa_cnst_slp_of_fa_rev_cnst slp_of_fa_bin_slp_of_fa_rev_bin slp_of_fa_un_slp_of_fa_rev_un)
    (metis (mono_tags, lifting) length_rev prod.simps(2) rev_swap slp_of_fa_un_slp_of_fa_rev_un)
next
  case (Powr fa1 fa2)
  then show ?case
    by (auto split: prod.splits simp: Let_def
      slp_of_fa_cnst_slp_of_fa_rev_cnst slp_of_fa_bin_slp_of_fa_rev_bin slp_of_fa_un_slp_of_fa_rev_un)
      (metis (no_types, lifting) Pair_inject length_rev prod.simps(2) rev_rev_ident slp_of_fa_bin_slp_of_fa_rev_bin)
next
  case (Ln fa)
  then show ?case
    by (auto split: prod.splits simp: Let_def
      slp_of_fa_cnst_slp_of_fa_rev_cnst slp_of_fa_bin_slp_of_fa_rev_bin slp_of_fa_un_slp_of_fa_rev_un)
    (metis (mono_tags, lifting) length_rev prod.simps(2) rev_swap slp_of_fa_un_slp_of_fa_rev_un)
next
  case (Power fa x2a)
  then show ?case
    by (auto split: prod.splits simp: Let_def
      slp_of_fa_cnst_slp_of_fa_rev_cnst slp_of_fa_bin_slp_of_fa_rev_bin slp_of_fa_un_slp_of_fa_rev_un)
    (metis (mono_tags, lifting) length_rev prod.simps(2) rev_swap slp_of_fa_un_slp_of_fa_rev_un)
next
  case (Floor fa)
  then show ?case
    by (auto split: prod.splits simp: Let_def
      slp_of_fa_cnst_slp_of_fa_rev_cnst slp_of_fa_bin_slp_of_fa_rev_bin slp_of_fa_un_slp_of_fa_rev_un)
    (metis (mono_tags, lifting) length_rev prod.simps(2) rev_swap slp_of_fa_un_slp_of_fa_rev_un)
next
  case (Var x)
  then show ?case
    by (auto split: prod.splits simp: Let_def
      slp_of_fa_cnst_slp_of_fa_rev_cnst slp_of_fa_bin_slp_of_fa_rev_bin slp_of_fa_un_slp_of_fa_rev_un)
next
  case (Num x)
  then show ?case
    by (auto split: prod.splits simp: Let_def
      slp_of_fa_cnst_slp_of_fa_rev_cnst slp_of_fa_bin_slp_of_fa_rev_bin slp_of_fa_un_slp_of_fa_rev_un)
qed

lemma slp_of_fa_code[code]:
  "slp_of_fa fa M slp = (let (M, slp', _) = slp_of_fa_rev fa M (rev slp) (length slp) in (M, rev slp'))"
  using slp_of_fa_rev[of fa M "rev slp"]
  by (auto split: prod.splits)

definition "norm2_slp n = slp_of_fas [floatarith.Inverse (norm2⇩_e n)]"

unbundle no_floatarith_notation

end

Theory Affine_Approximation

 section ‹Approximation with Affine Forms›
theory Affine_Approximation
imports
  "HOL-Decision_Procs.Approximation"
  "HOL-Library.Monad_Syntax"
  "HOL-Library.Mapping"
  Executable_Euclidean_Space
  Affine_Form
  Straight_Line_Program
begin
text ‹\label{sec:approxaffine}›

lemma convex_on_imp_above_tangent:― ‹TODO: generalizes @{thm convex_on_imp_above_tangent}›
  assumes convex: "convex_on A f" and connected: "connected A"
  assumes c: "c ∈ A" and x : "x ∈ A"
  assumes deriv: "(f has_field_derivative f') (at c within A)"
  shows   "f x - f c ≥ f' * (x - c)"
proof (cases x c rule: linorder_cases)
  assume xc: "x > c"
  let ?A' = "{c<..<x}"
  have subs: "?A' ⊆ A" using xc x c
    by (simp add: connected connected_contains_Ioo)
  have "at c within ?A' ≠ bot"
    using xc
    by (simp add: at_within_eq_bot_iff)
  moreover from deriv have "((λy. (f y - f c) / (y - c)) ⤏ f') (at c within ?A')"
    unfolding has_field_derivative_iff using subs
    by (blast intro: tendsto_mono at_le)
  moreover from eventually_at_right_real[OF xc]
    have "eventually (λy. (f y - f c) / (y - c) ≤ (f x - f c) / (x - c)) (at_right c)"
  proof eventually_elim
    fix y assume y: "y ∈ {c<..<x}"
    with convex connected x c have "f y ≤ (f x - f c) / (x - c) * (y - c) + f c"
      using interior_subset[of A]
      by (intro convex_onD_Icc' convex_on_subset[OF convex] connected_contains_Icc) auto
    hence "f y - f c ≤ (f x - f c) / (x - c) * (y - c)" by simp
    thus "(f y - f c) / (y - c) ≤ (f x - f c) / (x - c)" using y xc by (simp add: divide_simps)
  qed
  hence "eventually (λy. (f y - f c) / (y - c) ≤ (f x - f c) / (x - c)) (at c within ?A')"
    by (simp add: eventually_at_filter eventually_mono)
  ultimately have "f' ≤ (f x - f c) / (x - c)" by (simp add: tendsto_upperbound)
  thus ?thesis using xc by (simp add: field_simps)
next
  assume xc: "x < c"
  let ?A' = "{x<..<c}"
  have subs: "?A' ⊆ A" using xc x c
    by (simp add: connected connected_contains_Ioo)
  have "at c within ?A' ≠ bot"
    using xc
    by (simp add: at_within_eq_bot_iff)
  moreover from deriv have "((λy. (f y - f c) / (y - c)) ⤏ f') (at c within ?A')"
    unfolding has_field_derivative_iff using subs
    by (blast intro: tendsto_mono at_le)
  moreover from eventually_at_left_real[OF xc]
    have "eventually (λy. (f y - f c) / (y - c) ≥ (f x - f c) / (x - c)) (at_left c)"
  proof eventually_elim
    fix y assume y: "y ∈ {x<..<c}"
    with convex connected x c have "f y ≤ (f x - f c) / (c - x) * (c - y) + f c"
      using interior_subset[of A]
      by (intro convex_onD_Icc'' convex_on_subset[OF convex] connected_contains_Icc) auto
    hence "f y - f c ≤ (f x - f c) * ((c - y) / (c - x))" by simp
    also have "(c - y) / (c - x) = (y - c) / (x - c)" using y xc by (simp add: field_simps)
    finally show "(f y - f c) / (y - c) ≥ (f x - f c) / (x - c)" using y xc
      by (simp add: divide_simps)
  qed
  hence "eventually (λy. (f y - f c) / (y - c) ≥ (f x - f c) / (x - c)) (at c within ?A')"
    by (simp add: eventually_at_filter eventually_mono)
  ultimately have "f' ≥ (f x - f c) / (x - c)" by (simp add: tendsto_lowerbound)
  thus ?thesis using xc by (simp add: field_simps)
qed simp_all


text ‹Approximate operations on affine forms.›

lemma Affine_notempty[intro, simp]: "Affine X ≠ {}"
  by (auto simp: Affine_def valuate_def)

lemma truncate_up_lt: "x < y ⟹ x < truncate_up prec y"
  by (rule less_le_trans[OF _ truncate_up])

lemma truncate_up_pos_eq[simp]: "0 < truncate_up p x ⟷ 0 < x"
  by (auto simp: truncate_up_lt) (metis (poly_guards_query) not_le truncate_up_nonpos)

lemma inner_scaleR_pdevs_0: "inner_scaleR_pdevs 0 One_pdevs = zero_pdevs"
  unfolding inner_scaleR_pdevs_def
  by transfer (auto simp: unop_pdevs_raw_def)

lemma Affine_aform_of_point_eq[simp]: "Affine (aform_of_point p) = {p}"
  by (simp add: Affine_aform_of_ivl aform_of_point_def)

lemma mem_Affine_aform_of_point: "x ∈ Affine (aform_of_point x)"
  by simp

lemma
  aform_val_aform_of_ivl_innerE:
  assumes "e ∈ UNIV → {-1 .. 1}"
  assumes "a ≤ b" "c ∈ Basis"
  obtains f where "aform_val e (aform_of_ivl a b) ∙ c = aform_val f (aform_of_ivl (a ∙ c) (b ∙ c))"
    "f ∈ UNIV → {-1 .. 1}"
proof -
  have [simp]: "a ∙ c ≤ b ∙ c"
    using assms by (auto simp: eucl_le[where 'a='a])
  have "(λx. x ∙ c) ` Affine (aform_of_ivl a b) = Affine (aform_of_ivl (a ∙ c) (b ∙ c))"
    using assms
    by (auto simp: Affine_aform_of_ivl eucl_le[where 'a='a]
      image_eqI[where x="∑i∈Basis. (if i = c then x else a ∙ i) *⇩_R i" for x])
  then obtain f where
      "aform_val e (aform_of_ivl a b) ∙ c = aform_val f (aform_of_ivl (a ∙ c) (b ∙ c))"
      "f ∈ UNIV → {-1 .. 1}"
    using assms
    by (force simp: Affine_def valuate_def)
  thus ?thesis ..
qed

lift_definition coord_pdevs::"nat ⇒ real pdevs" is "λn i. if i = n then 1 else 0" by auto

lemma pdevs_apply_coord_pdevs [simp]: "pdevs_apply (coord_pdevs i) x = (if x = i then 1 else 0)"
  by transfer simp

lemma degree_coord_pdevs[simp]: "degree (coord_pdevs i) = Suc i"
  by (auto intro!: degree_eqI)

lemma pdevs_val_coord_pdevs[simp]: "pdevs_val e (coord_pdevs i) = e i"
  by (auto simp: pdevs_val_sum if_distrib sum.delta cong: if_cong)

definition "aforms_of_ivls ls us = map
    (λ(i, (l, u)). ((l + u)/2, scaleR_pdevs ((u - l)/2) (coord_pdevs i)))
    (zip [0..<length ls] (zip ls us))"

lemma
  aforms_of_ivls:
  assumes "length ls = length us" "length xs = length ls"
  assumes "⋀i. i < length xs ⟹ xs ! i ∈ {ls ! i .. us ! i}"
  shows "xs ∈ Joints (aforms_of_ivls ls us)"
proof -
  {
    fix i assume "i < length xs"
    then have "∃e. e ∈ {-1 .. 1} ∧ xs ! i = (ls ! i + us ! i) / 2 + e * (us ! i - ls ! i) / 2"
      using assms
      by (force intro!: exI[where x="(xs ! i - (ls ! i + us ! i) / 2) / (us ! i - ls ! i) * 2"]
          simp: divide_simps algebra_simps)
  } then obtain e where e: "e i ∈ {-1 .. 1}"
    "xs ! i = (ls ! i + us ! i) / 2 + e i * (us ! i - ls ! i) / 2" 
    if "i < length xs" for i
    using that by metis
  define e' where "e' i = (if i < length xs then e i else 0)" for i
  show ?thesis
    using e assms
    by (auto simp: aforms_of_ivls_def Joints_def valuate_def e'_def aform_val_def
        intro!: image_eqI[where x=e'] nth_equalityI)
qed


subsection ‹Approximate Operations›

definition "max_pdev x = fold (λx y. if infnorm (snd x) ≥ infnorm (snd y) then x else y) (list_of_pdevs x) (0, 0)"


subsubsection ‹set of generated endpoints›

fun points_of_list where
  "points_of_list x0 [] = [x0]"
| "points_of_list x0 ((i, x)#xs) = (points_of_list (x0 + x) xs @ points_of_list (x0 - x) xs)"

primrec points_of_aform where
  "points_of_aform (x, xs) = points_of_list x (list_of_pdevs xs)"


subsubsection ‹Approximate total deviation›

definition sum_list'::"nat ⇒ 'a list ⇒ 'a::executable_euclidean_space"
  where "sum_list' p xs = fold (λa b. eucl_truncate_up p (a + b)) xs 0"

definition "tdev' p x = sum_list' p (map (abs o snd) (list_of_pdevs x))"

lemma
  eucl_fold_mono:
  fixes f::"'a::ordered_euclidean_space⇒'a⇒'a"
  assumes mono: "⋀w x y z. w ≤ x ⟹ y ≤ z ⟹ f w y ≤ f x z"
  shows "x ≤ y ⟹ fold f xs x ≤ fold f xs y"
  by (induct xs arbitrary: x y) (auto simp: mono)

lemma sum_list_add_le_fold_eucl_truncate_up:
  fixes z::"'a::executable_euclidean_space"
  shows "sum_list xs + z ≤ fold (λx y. eucl_truncate_up p (x + y)) xs z"
proof (induct xs arbitrary: z)
  case (Cons x xs)
  have "sum_list (x # xs) + z = sum_list xs + (z + x)"
    by simp
  also have "… ≤ fold (λx y. eucl_truncate_up p (x + y)) xs (z + x)"
    using Cons by simp
  also have "… ≤ fold (λx y. eucl_truncate_up p (x + y)) xs (eucl_truncate_up p (x + z))"
    by (auto intro!: add_mono eucl_fold_mono eucl_truncate_up eucl_truncate_up_mono simp: ac_simps)
  finally show ?case by simp
qed simp

lemma sum_list_le_sum_list':
  "sum_list xs ≤ sum_list' p xs"
  unfolding sum_list'_def
  using sum_list_add_le_fold_eucl_truncate_up[of xs 0] by simp

lemma sum_list'_sum_list_le:
  "y ≤ sum_list xs ⟹ y ≤ sum_list' p xs"
  by (metis sum_list_le_sum_list' order.trans)

lemma tdev': "tdev x ≤ tdev' p x"
  unfolding tdev'_def
proof -
  have "tdev x = (∑i = 0 ..< degree x. ¦pdevs_apply x i¦)"
    by (auto intro!: sum.mono_neutral_cong_left simp: tdev_def)
  also have "… = (∑i ← rev [0 ..< degree x]. ¦pdevs_apply x i¦)"
    by (metis atLeastLessThan_upt sum_list_rev rev_map sum_set_upt_conv_sum_list_nat)
  also have
    "… = sum_list (map (λxa. ¦pdevs_apply x xa¦) [xa←rev [0..<degree x] . pdevs_apply x xa ≠ 0])"
    unfolding filter_map map_map o_def
    by (subst sum_list_map_filter) auto
  also note sum_list_le_sum_list'[of _ p]
  also have "[xa←rev [0..<degree x] . pdevs_apply x xa ≠ 0] =
      rev (sorted_list_of_set (pdevs_domain x))"
    by (subst rev_is_rev_conv[symmetric])
      (auto simp: filter_map rev_filter intro!: sorted_distinct_set_unique
        sorted_filter[of "λx. x", simplified] degree_gt)
  finally
  show "tdev x ≤ sum_list' p (map (abs ∘ snd) (list_of_pdevs x))"
    by (auto simp: list_of_pdevs_def o_def rev_map filter_map rev_filter)
qed

lemma tdev'_le: "x ≤ tdev y ⟹ x ≤ tdev' p y"
  by (metis order.trans tdev')

lemmas abs_pdevs_val_le_tdev' = tdev'_le[OF abs_pdevs_val_le_tdev]

lemma tdev'_uminus_pdevs[simp]: "tdev' p (uminus_pdevs x) = tdev' p x"
  by (auto simp: tdev'_def o_def rev_map filter_map rev_filter list_of_pdevs_def pdevs_domain_def)

abbreviation Radius::"'a::ordered_euclidean_space aform ⇒ 'a"
  where "Radius X ≡ tdev (snd X)"

abbreviation Radius'::"nat⇒'a::executable_euclidean_space aform ⇒ 'a"
  where "Radius' p X ≡ tdev' p (snd X)"

lemma Radius'_uminus_aform[simp]: "Radius' p (uminus_aform X) = Radius' p X"
  by (auto simp: uminus_aform_def)


subsubsection ‹truncate partial deviations›

definition trunc_pdevs_raw::"nat ⇒ (nat ⇒ 'a) ⇒ nat ⇒ 'a::executable_euclidean_space"
  where "trunc_pdevs_raw p x i = eucl_truncate_down p (x i)"

lemma nonzeros_trunc_pdevs_raw:
  "{i. trunc_pdevs_raw r x i ≠ 0} ⊆ {i. x i ≠ 0}"
  by (auto simp: trunc_pdevs_raw_def[abs_def])

lift_definition trunc_pdevs::"nat ⇒ 'a::executable_euclidean_space pdevs ⇒ 'a pdevs"
  is trunc_pdevs_raw
  by (auto intro!: finite_subset[OF nonzeros_trunc_pdevs_raw])

definition trunc_err_pdevs_raw::"nat ⇒ (nat ⇒ 'a) ⇒ nat ⇒ 'a::executable_euclidean_space"
  where "trunc_err_pdevs_raw p x i = trunc_pdevs_raw p x i - x i"

lemma nonzeros_trunc_err_pdevs_raw:
  "{i. trunc_err_pdevs_raw r x i ≠ 0} ⊆ {i. x i ≠ 0}"
  by (auto simp: trunc_pdevs_raw_def trunc_err_pdevs_raw_def[abs_def])

lift_definition trunc_err_pdevs::"nat ⇒ 'a::executable_euclidean_space pdevs ⇒ 'a pdevs"
  is trunc_err_pdevs_raw
  by (auto intro!: finite_subset[OF nonzeros_trunc_err_pdevs_raw])

term float_plus_down

lemma pdevs_apply_trunc_pdevs[simp]:
  fixes x y::"'a::euclidean_space"
  shows "pdevs_apply (trunc_pdevs p X) n = eucl_truncate_down p (pdevs_apply X n)"
  by transfer (simp add: trunc_pdevs_raw_def)

lemma pdevs_apply_trunc_err_pdevs[simp]:
  fixes x y::"'a::euclidean_space"
  shows "pdevs_apply (trunc_err_pdevs p X) n =
    eucl_truncate_down p (pdevs_apply X n) - (pdevs_apply X n)"
  by transfer (auto simp: trunc_err_pdevs_raw_def trunc_pdevs_raw_def)

lemma pdevs_val_trunc_pdevs:
  fixes x y::"'a::euclidean_space"
  shows "pdevs_val e (trunc_pdevs p X) = pdevs_val e X + pdevs_val e (trunc_err_pdevs p X)"
proof -
  have "pdevs_val e X + pdevs_val e (trunc_err_pdevs p X) =
      pdevs_val e (add_pdevs X (trunc_err_pdevs p X))"
    by simp
  also have "… = pdevs_val e (trunc_pdevs p X)"
    by (auto simp: pdevs_val_def trunc_pdevs_raw_def trunc_err_pdevs_raw_def)
  finally show ?thesis by simp
qed

lemma pdevs_val_trunc_err_pdevs:
  fixes x y::"'a::euclidean_space"
  shows "pdevs_val e (trunc_err_pdevs p X) = pdevs_val e (trunc_pdevs p X) - pdevs_val e X"
  by (simp add: pdevs_val_trunc_pdevs)

definition truncate_aform::"nat ⇒ 'a aform ⇒ 'a::executable_euclidean_space aform"
  where "truncate_aform p x = (eucl_truncate_down p (fst x), trunc_pdevs p (snd x))"

definition truncate_error_aform::"nat ⇒ 'a aform ⇒ 'a::executable_euclidean_space aform"
  where "truncate_error_aform p x =
    (eucl_truncate_down p (fst x) - fst x, trunc_err_pdevs p (snd x))"

lemma
  abs_aform_val_le:
  assumes "e ∈ UNIV → {- 1..1}"
  shows "abs (aform_val e X) ≤ eucl_truncate_up p (¦fst X¦ + tdev' p (snd X))"
proof -
  have "abs (aform_val e X) ≤ ¦fst X¦ + ¦pdevs_val e (snd X)¦"
    by (auto simp: aform_val_def intro!: abs_triangle_ineq)
  also have "¦pdevs_val e (snd X)¦ ≤ tdev (snd X)"
    using assms by (rule abs_pdevs_val_le_tdev)
  also note tdev'
  also note eucl_truncate_up
  finally show ?thesis by simp
qed


subsubsection ‹truncation with error bound›

definition "trunc_bound_eucl p s =
  (let
    d = eucl_truncate_down p s;
    ed = abs (d - s) in
  (d, eucl_truncate_up p ed))"

lemma trunc_bound_euclE:
  obtains err where
  "¦err¦ ≤ snd (trunc_bound_eucl p x)"
  "fst (trunc_bound_eucl p x) = x + err"
proof atomize_elim
  have "fst (trunc_bound_eucl p x) = x + (eucl_truncate_down p x - x)"
    (is "_ = _ + ?err")
    by (simp_all add: trunc_bound_eucl_def Let_def)
  moreover have "abs ?err ≤ snd (trunc_bound_eucl p x)"
    by (simp add: trunc_bound_eucl_def Let_def eucl_truncate_up)
  ultimately show "∃err. ¦err¦ ≤ snd (trunc_bound_eucl p x) ∧ fst (trunc_bound_eucl p x) = x + err"
    by auto
qed

definition "trunc_bound_pdevs p x = (trunc_pdevs p x, tdev' p (trunc_err_pdevs p x))"

lemma pdevs_apply_fst_trunc_bound_pdevs[simp]: "pdevs_apply (fst (trunc_bound_pdevs p x)) =
  pdevs_apply (trunc_pdevs p x)"
  by (simp add: trunc_bound_pdevs_def)

lemma trunc_bound_pdevsE:
  assumes "e ∈ UNIV → {- 1..1}"
  obtains err where
  "¦err¦ ≤ snd (trunc_bound_pdevs p x)"
  "pdevs_val e (fst ((trunc_bound_pdevs p x))) = pdevs_val e x + err"
proof atomize_elim
  have "pdevs_val e (fst (trunc_bound_pdevs p x)) = pdevs_val e x +
    pdevs_val e (add_pdevs (trunc_pdevs p x) (uminus_pdevs x))"
    (is "_ = _ + ?err")
    by (simp_all add: trunc_bound_pdevs_def Let_def)
  moreover have "abs ?err ≤ snd (trunc_bound_pdevs p x)"
    using assms
    by (auto simp add: pdevs_val_trunc_pdevs trunc_bound_pdevs_def Let_def eucl_truncate_up
      intro!: order_trans[OF abs_pdevs_val_le_tdev tdev'])
  ultimately show "∃err. ¦err¦ ≤ snd (trunc_bound_pdevs p x) ∧
      pdevs_val e (fst ((trunc_bound_pdevs p x))) = pdevs_val e x + err"
    by auto
qed

lemma
  degree_add_pdevs_le:
  assumes "degree X ≤ n"
  assumes "degree Y ≤ n"
  shows "degree (add_pdevs X Y) ≤ n"
  using assms
  by (auto intro!: degree_le)


lemma truncate_aform_error_aform_cancel:
  "aform_val e (truncate_aform p z) = aform_val e z + aform_val e (truncate_error_aform p z) "
  by (simp add: truncate_aform_def aform_val_def truncate_error_aform_def pdevs_val_trunc_pdevs)

lemma error_absE:
  assumes "abs err ≤ k"
  obtains e::real where "err = e * k" "e ∈ {-1 .. 1}"
  using assms
  by atomize_elim
    (safe intro!: exI[where x="err / abs k"] divide_atLeastAtMost_1_absI, auto)

lemma eucl_truncate_up_nonneg_eq_zero_iff:
  "x ≥ 0 ⟹ eucl_truncate_up p x = 0 ⟷ x = 0"
  by (metis (poly_guards_query) eq_iff eucl_truncate_up eucl_truncate_up_zero)

lemma
  aform_val_consume_error:
  assumes "abs err ≤ abs (pdevs_apply (snd X) n)"
  shows "aform_val (e(n := 0)) X + err = aform_val (e(n := err/pdevs_apply (snd X) n)) X"
  using assms
  by (auto simp add: aform_val_def)

lemma
  aform_val_consume_errorE:
  fixes X::"real aform"
  assumes "abs err ≤ abs (pdevs_apply (snd X) n)"
  obtains err' where "aform_val (e(n := 0)) X + err = aform_val (e(n := err')) X" "err' ∈ {-1 .. 1}"
  by atomize_elim
    (rule aform_val_consume_error assms aform_val_consume_error exI conjI
      divide_atLeastAtMost_1_absI)+

lemma
  degree_trunc_pdevs_le:
  assumes "degree X ≤ n"
  shows "degree (trunc_pdevs p X) ≤ n"
  using assms
  by (auto intro!: degree_le)

lemma pdevs_val_sum_less_degree:
  "pdevs_val e X = (∑i<d. e i *⇩_R pdevs_apply X i)" if "degree X ≤ d"
  unfolding pdevs_val_pdevs_domain
  apply (rule sum.mono_neutral_cong_left)
  using that
  by force+


subsubsection ‹general affine operation›

definition "affine_binop (X::real aform) Y a b c d k =
  (a * fst X + b * fst Y + c,
    pdev_upd (add_pdevs (scaleR_pdevs a (snd X)) (scaleR_pdevs b (snd Y))) k d)"

lemma pdevs_domain_One_pdevs[simp]: "pdevs_domain (One_pdevs::'a::executable_euclidean_space pdevs) =
  {0..<DIM('a)}"
  apply (auto simp: length_Basis_list split: if_splits)
  subgoal for i
    using nth_Basis_list_in_Basis[of i, where 'a='a]
    by (auto simp: length_Basis_list)
  done

lemma pdevs_val_One_pdevs:
  "pdevs_val e (One_pdevs::'a::executable_euclidean_space pdevs) = (∑i<DIM('a). e i *⇩_R Basis_list ! i)"
  by (auto simp: pdevs_val_pdevs_domain length_Basis_list intro!:sum.cong)

lemma affine_binop:
  assumes "degree_aforms [X, Y] ≤ k"
  shows "aform_val e (affine_binop X Y a b c d k) =
    a * aform_val e X + b * aform_val e Y + c + e k * d"
  using assms
  by (auto simp: aform_val_def affine_binop_def degrees_def
      pdevs_val_msum_pdevs degree_add_pdevs_le pdevs_val_One_pdevs Basis_list_real_def
      algebra_simps)

definition "affine_binop' p (X::real aform) Y a b c d k =
  (let
    ― ‹TODO: more round-off operations here?›
    (r, e1) = trunc_bound_eucl p (a * fst X + b * fst Y + c);
    (Z, e2) = trunc_bound_pdevs p (add_pdevs (scaleR_pdevs a (snd X)) (scaleR_pdevs b (snd Y)))
  in
    (r, pdev_upd Z k (sum_list' p [e1, e2, d]))
  )"

lemma sum_list'_noneg_eq_zero_iff: "sum_list' p xs = 0 ⟷ (∀x∈set xs. x = 0)" if "⋀x. x ∈ set xs ⟹ x ≥ 0"
proof safe
  fix x assume x: "sum_list' p xs = 0" "x ∈ set xs"
  from that have "0 ≤ sum_list xs" by (auto intro!: sum_list_nonneg)
  with that x have "sum_list xs = 0"
    by (metis antisym sum_list_le_sum_list')
  then have "(∑i<length xs.  xs ! i) = 0"
    by (auto simp: sum_list_sum_nth atLeast0LessThan)
  then show "x = 0" using x(2) that
    by (subst (asm) sum_nonneg_eq_0_iff) (auto simp: in_set_conv_nth)
next
  show "∀x∈set xs. x = 0 ⟹ sum_list' p xs = 0"
    by (induction xs) (auto simp: sum_list'_def)
qed

lemma affine_binop'E:
  assumes deg: "degree_aforms [X, Y] ≤ k"
  assumes e: "e ∈ UNIV → {- 1..1}"
  assumes d: "abs u ≤ d"
  obtains ek where
    "a * aform_val e X + b * aform_val e Y + c + u = aform_val (e(k:=ek)) (affine_binop' p X Y a b c d k)"
    "ek ∈ {-1 .. 1}"
proof -
  have "a * aform_val e X + b * aform_val e Y + c + u =
    (a * fst X + b * fst Y + c) + pdevs_val e (add_pdevs (scaleR_pdevs a (snd X)) (scaleR_pdevs b (snd Y))) + u"
    (is "_ = ?c + pdevs_val _ ?ps + _")
    by (auto simp: aform_val_def algebra_simps)

  from trunc_bound_euclE[of p ?c] obtain ec where ec: "abs ec ≤ snd (trunc_bound_eucl p ?c)"
    "fst (trunc_bound_eucl p ?c) - ec = ?c"
    by (auto simp: algebra_simps)

  moreover

  from trunc_bound_pdevsE[OF e, of p ?ps]
  obtain eps where eps: "¦eps¦ ≤ snd (trunc_bound_pdevs p ?ps)"
    "pdevs_val e (fst (trunc_bound_pdevs p ?ps)) - eps = pdevs_val e ?ps"
    by (auto simp: algebra_simps)

  moreover
  define ek where "ek = (u - ec - eps)/
        sum_list' p [snd (trunc_bound_eucl p ?c), snd (trunc_bound_pdevs p ?ps), d]"
  have "degree (fst (trunc_bound_pdevs p ?ps)) ≤
      degree_aforms [X, Y]"
    by (auto simp: trunc_bound_pdevs_def degrees_def intro!: degree_trunc_pdevs_le degree_add_pdevs_le)
  moreover
  from this have "pdevs_apply (fst (trunc_bound_pdevs p ?ps)) k = 0"
    using deg order_trans by blast
  ultimately have "a * aform_val e X + b * aform_val e Y + c + u =
    aform_val (e(k:=ek)) (affine_binop' p X Y a b c d k)"
    apply (auto simp: affine_binop'_def algebra_simps aform_val_def split: prod.splits)
    subgoal for x y z
      apply (cases "sum_list' p [x, z, d] = 0")
      subgoal
        apply simp
        apply (subst (asm) sum_list'_noneg_eq_zero_iff)
        using d deg
        by auto
      subgoal
        apply (simp add: divide_simps algebra_simps ek_def)
        using ‹pdevs_apply (fst (trunc_bound_pdevs p (add_pdevs (scaleR_pdevs a (snd X)) (scaleR_pdevs b (snd Y))))) k = 0› by auto
      done
    done
  moreover have "ek ∈ {-1 .. 1}"
    unfolding ek_def
    apply (rule divide_atLeastAtMost_1_absI)
    apply (rule abs_triangle_ineq4[THEN order_trans])
    apply (rule order_trans)
     apply (rule add_right_mono)
     apply (rule abs_triangle_ineq4)
    using ec(1) eps(1)
    by (auto simp: sum_list'_def eucl_truncate_up_real_def add.assoc
        intro!: order_trans[OF _ abs_ge_self] order_trans[OF _ truncate_up_le] add_mono d )
  ultimately show ?thesis ..
qed

subsubsection ‹Inf/Sup›

definition "Inf_aform' p X = eucl_truncate_down p (fst X - tdev' p (snd X))"

definition "Sup_aform' p X = eucl_truncate_up p (fst X + tdev' p (snd X))"

lemma Inf_aform':
  shows "Inf_aform' p X ≤ Inf_aform X"
  unfolding Inf_aform_def Inf_aform'_def
  by (auto intro!: eucl_truncate_down_le add_left_mono tdev')

lemma Sup_aform':
  shows "Sup_aform X ≤ Sup_aform' p X"
  unfolding Sup_aform_def Sup_aform'_def
  by (rule eucl_truncate_up_le add_left_mono tdev')+

lemma Inf_aform_le_Sup_aform[intro]:
  "Inf_aform X ≤ Sup_aform X"
  by (simp add: Inf_aform_def Sup_aform_def algebra_simps)

lemma Inf_aform'_le_Sup_aform'[intro]:
  "Inf_aform' p X ≤ Sup_aform' p X"
  by (metis Inf_aform' Inf_aform_le_Sup_aform Sup_aform' order.trans)

definition
  "ivls_of_aforms prec = map (λa. Interval' (float_of (Inf_aform' prec a)) (float_of(Sup_aform' prec a)))"

lemma
  assumes "⋀i. e'' i ≤ 1"
  assumes "⋀i. -1 ≤ e'' i"
  shows Inf_aform'_le: "Inf_aform' p r ≤ aform_val e'' r"
    and Sup_aform'_le: "aform_val e'' r ≤ Sup_aform' p r"
  by (auto intro!: order_trans[OF Inf_aform'] order_trans[OF _ Sup_aform'] Inf_aform Sup_aform
    simp: Affine_def valuate_def intro!: image_eqI[where x=e''] assms)


lemma InfSup_aform'_in_float[intro, simp]:
  "Inf_aform' p X ∈ float" "Sup_aform' p X ∈ float"
  by (auto simp: Inf_aform'_def eucl_truncate_down_real_def
      Sup_aform'_def eucl_truncate_up_real_def)

theorem ivls_of_aforms: "xs ∈ Joints XS ⟹ bounded_by xs (ivls_of_aforms prec XS)"
  by (auto simp: bounded_by_def ivls_of_aforms_def Affine_def valuate_def Pi_iff set_of_eq
      intro!: Inf_aform'_le Sup_aform'_le
      dest!: nth_in_AffineI split: Interval'_splits)

definition "isFDERIV_aform prec N xs fas AS = isFDERIV_approx prec N xs fas (ivls_of_aforms prec AS)"

theorem isFDERIV_aform:
  assumes "isFDERIV_aform prec N xs fas AS"
  assumes "vs ∈ Joints AS"
  shows "isFDERIV N xs fas vs"
  apply (rule isFDERIV_approx)
  apply (rule ivls_of_aforms)
  apply (rule assms)
  apply (rule assms[unfolded isFDERIV_aform_def])
  done

definition "env_len env l = (∀xs ∈ env. length xs = l)"

lemma env_len_takeI: "env_len xs d1 ⟹ d1 ≥ d ⟹ env_len (take d ` xs) d"
  by (auto simp: env_len_def)

subsection ‹Min Range approximation›

lemma
  linear_lower:
  fixes x::real
  assumes "⋀x. x ∈ {a .. b} ⟹ (f has_field_derivative f' x) (at x within {a .. b})"
  assumes "⋀x. x ∈ {a .. b} ⟹ f' x ≤ u"
  assumes "x ∈ {a .. b}"
  shows "f b + u * (x - b) ≤ f x"
proof -
  from assms(2-)
    mvt_very_simple[of x b f "λx. (*) (f' x)",
      rule_format,
      OF _ has_derivative_subset[OF assms(1)[simplified has_field_derivative_def]]]
  obtain y where "y ∈ {x .. b}"  "f b - f x = (b - x) * f' y"
    by (auto simp: Bex_def ac_simps)
  moreover hence "f' y ≤ u" using assms by auto
  ultimately have "f b - f x ≤ (b - x) * u"
    by (auto intro!: mult_left_mono)
  thus ?thesis by (simp add: algebra_simps)
qed

lemma
  linear_lower2:
  fixes x::real
  assumes "⋀x. x ∈ {a .. b} ⟹ (f has_field_derivative f' x) (at x within {a .. b})"
  assumes "⋀x. x ∈ {a .. b} ⟹ l ≤ f' x"
  assumes "x ∈ {a .. b}"
  shows "f x ≥ f a + l * (x - a)"
proof -
  from assms(2-)
    mvt_very_simple[of a x f "λx. (*) (f' x)",
      rule_format,
      OF _ has_derivative_subset[OF assms(1)[simplified has_field_derivative_def]]]
  obtain y where "y ∈ {a .. x}"  "f x - f a = (x - a) * f' y"
    by (auto simp: Bex_def ac_simps)
  moreover hence "l ≤ f' y" using assms by auto
  ultimately have "(x - a) * l ≤ f x - f a"
    by (auto intro!: mult_left_mono)
  thus ?thesis by (simp add: algebra_simps)
qed

lemma
  linear_upper:
  fixes x::real
  assumes "⋀x. x ∈ {a .. b} ⟹ (f has_field_derivative f' x) (at x within {a .. b})"
  assumes "⋀x. x ∈ {a .. b} ⟹ f' x ≤ u"
  assumes "x ∈ {a .. b}"
  shows "f x ≤ f a + u * (x - a)"
proof -
  from assms(2-)
    mvt_very_simple[of a x f "λx. (*) (f' x)",
      rule_format,
      OF _ has_derivative_subset[OF assms(1)[simplified has_field_derivative_def]]]
  obtain y where "y ∈ {a .. x}"  "f x - f a = (x - a) * f' y"
    by (auto simp: Bex_def ac_simps)
  moreover hence "f' y ≤ u" using assms by auto
  ultimately have "(x - a) * u ≥ f x - f a"
    by (auto intro!: mult_left_mono)
  thus ?thesis by (simp add: algebra_simps)
qed

lemma
  linear_upper2:
  fixes x::real
  assumes "⋀x. x ∈ {a .. b} ⟹ (f has_field_derivative f' x) (at x within {a .. b})"
  assumes "⋀x. x ∈ {a .. b} ⟹ l ≤ f' x"
  assumes "x ∈ {a .. b}"
  shows "f x ≤ f b + l * (x - b)"
proof -
  from assms(2-)
    mvt_very_simple[of x b f "λx. (*) (f' x)",
      rule_format,
      OF _ has_derivative_subset[OF assms(1)[simplified has_field_derivative_def]]]
  obtain y where "y ∈ {x .. b}"  "f b - f x = (b - x) * f' y"
    by (auto simp: Bex_def ac_simps)
  moreover hence "l ≤ f' y" using assms by auto
  ultimately have "f b - f x ≥ (b - x) * l"
    by (auto intro!: mult_left_mono)
  thus ?thesis by (simp add: algebra_simps)
qed

lemma linear_enclosure:
  fixes x::real
  assumes "⋀x. x ∈ {a .. b} ⟹ (f has_field_derivative f' x) (at x within {a .. b})"
  assumes "⋀x. x ∈ {a .. b} ⟹ f' x ≤ u"
  assumes "x ∈ {a .. b}"
  shows "f x ∈ {f b + u * (x - b) .. f a + u * (x - a)}"
  using linear_lower[OF assms] linear_upper[OF assms]
  by auto

definition "mid_err ivl = ((lower ivl + upper ivl::float)/2, (upper ivl - lower ivl)/2)"

lemma degree_aform_uminus_aform[simp]: "degree_aform (uminus_aform X) = degree_aform X"
  by (auto simp: uminus_aform_def)


subsubsection ‹Addition›

definition add_aform::"'a::real_vector aform ⇒ 'a aform ⇒ 'a aform"
  where "add_aform x y = (fst x + fst y, add_pdevs (snd x) (snd y))"

lemma aform_val_add_aform:
  shows "aform_val e (add_aform X Y) = aform_val e X + aform_val e Y"
  by (auto simp: add_aform_def aform_val_def)

type_synonym aform_err = "real aform × real"

definition add_aform'::"nat ⇒ aform_err ⇒ aform_err ⇒ aform_err"
  where "add_aform' p x y =
    (let
      z0 = trunc_bound_eucl p (fst (fst x) + fst (fst y));
      z = trunc_bound_pdevs p (add_pdevs (snd (fst x)) (snd (fst y)))
      in ((fst z0, fst z), (sum_list' p [snd z0, snd z, abs (snd x), abs (snd y)])))"

abbreviation degree_aform_err::"aform_err ⇒ nat"
  where "degree_aform_err X ≡ degree_aform (fst X)"

lemma degree_aform_err_add_aform':
  assumes "degree_aform_err x ≤ n"
  assumes "degree_aform_err y ≤ n"
  shows "degree_aform_err (add_aform' p x y) ≤ n"
  using assms
  by (auto simp: add_aform'_def Let_def trunc_bound_pdevs_def
      intro!: degree_pdev_upd_le degree_trunc_pdevs_le degree_add_pdevs_le)

definition "aform_err e Xe = {aform_val e (fst Xe) - snd Xe .. aform_val e (fst Xe) + snd Xe::real}"

lemma aform_errI: "x ∈ aform_err e Xe"
  if "abs (x - aform_val e (fst Xe)) ≤ snd Xe"
  using that by (auto simp: aform_err_def abs_real_def algebra_simps split: if_splits)

lemma add_aform':
  assumes e: "e ∈ UNIV → {- 1..1}"
  assumes x: "x ∈ aform_err e X"
  assumes y: "y ∈ aform_err e Y"
  shows "x + y ∈ aform_err e (add_aform' p X Y)"
proof -
  let ?t1 = "trunc_bound_eucl p (fst (fst X) + fst (fst Y))"
  from trunc_bound_euclE
  obtain e1 where abs_e1: "¦e1¦ ≤ snd ?t1" and e1: "fst ?t1 = fst (fst X) + fst (fst Y) + e1"
    by blast
  let ?t2 = "trunc_bound_pdevs p (add_pdevs (snd (fst X)) (snd (fst Y)))"
  from trunc_bound_pdevsE[OF e, of p "add_pdevs (snd (fst X)) (snd (fst Y))"]
  obtain e2 where abs_e2: "¦e2¦ ≤ snd (?t2)"
    and e2: "pdevs_val e (fst ?t2) = pdevs_val e (add_pdevs (snd (fst X)) (snd (fst Y))) + e2"
    by blast

  have e_le: "¦e1 + e2 + snd X + snd Y¦ ≤ snd (add_aform' p (X) Y)"
    apply (auto simp: add_aform'_def Let_def )
    apply (rule sum_list'_sum_list_le)
    apply (simp add: add.assoc)
    by (intro order.trans[OF abs_triangle_ineq] add_mono abs_e1 abs_e2 order_refl)
  then show ?thesis
    apply (intro aform_errI)
    using x y abs_e1 abs_e2
    apply (simp add: aform_val_def aform_err_def add_aform_def add_aform'_def Let_def e1 e2 assms)
    by (auto intro!: order_trans[OF _ sum_list_le_sum_list'] )
qed


subsubsection ‹Scaling›

definition aform_scaleR::"real aform ⇒ 'a::real_vector ⇒ 'a aform"
  where "aform_scaleR x y = (fst x *⇩_R y, pdevs_scaleR (snd x) y)"

lemma aform_val_scaleR_aform[simp]:
  shows "aform_val e (aform_scaleR X y) = aform_val e X *⇩_R y"
  by (auto simp: aform_scaleR_def aform_val_def scaleR_left_distrib)


subsubsection ‹Multiplication›

lemma aform_val_mult_exact:
  "aform_val e x * aform_val e y =
    fst x * fst y +
    pdevs_val e (add_pdevs (scaleR_pdevs (fst y) (snd x)) (scaleR_pdevs (fst x) (snd y))) +
    (∑i<d. e i *⇩_R pdevs_apply (snd x) i)*(∑i<d. e i *⇩_R pdevs_apply (snd y) i)"
   if "degree (snd x) ≤ d" "degree (snd y) ≤ d"
   using that
  by (auto simp: pdevs_val_sum_less_degree[where d=d] aform_val_def algebra_simps)

lemma sum_times_bound:― ‹TODO: this gives better bounds for the remainder of multiplication›
  "(∑i<d. e i * f i::real) * (∑i<d. e i * g i) =
   (∑i<d. (e i)⇧² * (f i * g i)) +
   (∑(i, j) | i < j ∧ j < d. (e i * e j) * (f j * g i + f i * g j))" for d::nat
proof -
  have "(∑i<d. e i * f i)*(∑i<d. e i * g i) = (∑(i, j)∈{..<d} × {..<d}. e i * f i * (e j * g j))"
    unfolding sum_product sum.cartesian_product ..
  also have "… = (∑(i, j)∈{..<d} × {..<d} ∩ {(i, j). i = j}. e i * f i * (e j * g j)) +
    ((∑(i, j)∈{..<d} × {..<d} ∩ {(i, j). i < j}. e i * f i * (e j * g j)) +
    (∑(i, j)∈{..<d} × {..<d} ∩ {(i, j). j < i}. e i * f i * (e j * g j)))"
    (is "_ = ?a + (?b + ?c)")
    by (subst sum.union_disjoint[symmetric], force, force, force)+ (auto intro!: sum.cong)
  also have "?c = (∑(i, j)∈{..<d} × {..<d} ∩ {(i, j). i < j}. e i * f j * (e j * g i))"
    by (rule sum.reindex_cong[of "λ(x, y). (y, x)"]) (auto intro!: inj_onI)
  also have "?b + … = (∑(i, j)∈{..<d} × {..<d} ∩ {(i, j). i < j}. (e i * e j) * (f j * g i + f i * g j))"
    by (auto simp: algebra_simps sum.distrib split_beta')
  also have "… = (∑(i, j) | i < j ∧ j < d. (e i * e j) * (f j * g i + f i * g j))"
    by (rule sum.cong) auto
  also have "?a = (∑i<d. (e i)⇧² * (f i * g i))"
    by (rule sum.reindex_cong[of "λi. (i, i)"]) (auto simp: power2_eq_square intro!: inj_onI)
  finally show ?thesis by simp
qed

definition mult_aform::"aform_err ⇒ aform_err ⇒ aform_err"
  where "mult_aform x y = ((fst (fst x) * fst (fst y),
    (add_pdevs (scaleR_pdevs (fst (fst y)) (snd (fst x))) (scaleR_pdevs (fst (fst x)) (snd (fst y))))),
     (tdev (snd (fst x)) * tdev (snd (fst y)) +
      abs (snd x) * (abs (fst (fst y)) + Radius (fst y)) +
      abs (snd y) * (abs (fst (fst x)) + Radius (fst x)) + abs (snd x) * abs (snd y)
     ))"

lemma mult_aformE:
  fixes X Y::"aform_err"
  assumes e: "e ∈ UNIV → {- 1..1}"
  assumes x: "x ∈ aform_err e X"
  assumes y: "y ∈ aform_err e Y"
  shows "x * y ∈ aform_err e (mult_aform X Y)"
proof -
  define ex where "ex ≡ x - aform_val e (fst X)"
  define ey where "ey ≡ y - aform_val e (fst Y)"

  have [intro, simp]: "¦ex¦ ≤ ¦snd X¦" "¦ey¦ ≤ ¦snd Y¦"
    using x y
    by (auto simp: ex_def ey_def aform_err_def)
  have "x * y =
    fst (fst X) * fst (fst Y) +
    fst (fst Y) * pdevs_val e (snd (fst X)) +
    fst (fst X) * pdevs_val e (snd (fst Y)) +

    (pdevs_val e (snd (fst X)) * pdevs_val e (snd (fst Y)) +
    ex * (fst (fst Y) + pdevs_val e (snd (fst Y))) +
    ey * (fst (fst X) + pdevs_val e (snd (fst X))) +
    ex * ey)"
    (is "_ = ?c + ?d + ?e + ?err")
    by (auto simp: ex_def ey_def algebra_simps aform_val_def)

  have abs_err: "abs ?err ≤ snd (mult_aform X Y)"
    by (auto simp: mult_aform_def abs_mult
        intro!: abs_triangle_ineq[THEN order_trans] add_mono mult_mono
          abs_pdevs_val_le_tdev e)
  show ?thesis
    apply (auto simp: intro!: aform_errI order_trans[OF _ abs_err])
    apply (subst mult_aform_def)
    apply (auto simp: aform_val_def ex_def ey_def algebra_simps)
    done
qed

definition mult_aform'::"nat ⇒ aform_err ⇒ aform_err ⇒ aform_err"
  where "mult_aform' p x y = (
    let
      (fx, sx) = x;
      (fy, sy) = y;
      ex = abs sx;
      ey = abs sy;
      z0 = trunc_bound_eucl p (fst fx * fst fy);
      u = trunc_bound_pdevs p (scaleR_pdevs (fst fy) (snd fx));
      v = trunc_bound_pdevs p (scaleR_pdevs (fst fx) (snd fy));
      w = trunc_bound_pdevs p (add_pdevs (fst u) (fst v));
      tx = tdev' p (snd fx);
      ty = tdev' p (snd fy);
      l = truncate_up p (tx * ty);
      ee = truncate_up p (ex * ey);
      e1 = truncate_up p (ex * truncate_up p (abs (fst fy) + ty));
      e2 = truncate_up p (ey * truncate_up p (abs (fst fx) + tx))
    in
      ((fst z0, (fst w)), (sum_list' p [ee, e1, e2, l, snd z0, snd u, snd v, snd w])))"

lemma aform_errE:
  "abs (x - aform_val e (fst X)) ≤ snd X"
  if "x ∈ aform_err e X"
  using that by (auto simp: aform_err_def)

lemma mult_aform'E:
  fixes X Y::"aform_err"
  assumes e: "e ∈ UNIV → {- 1..1}"
  assumes x: "x ∈ aform_err e X"
  assumes y: "y ∈ aform_err e Y"
  shows "x * y ∈ aform_err e (mult_aform' p X Y)"
proof -
  let ?z0 = "trunc_bound_eucl p (fst (fst X) * fst (fst Y))"
  from trunc_bound_euclE
  obtain e1 where abs_e1: "¦e1¦ ≤ snd ?z0" and e1: "fst ?z0 = fst (fst X) * fst (fst Y) + e1"
    by blast
  let ?u = "trunc_bound_pdevs p (scaleR_pdevs (fst (fst Y)) (snd (fst X)))"
  from trunc_bound_pdevsE[OF e]
  obtain e2 where abs_e2: "¦e2¦ ≤ snd (?u)"
    and e2: "pdevs_val e (fst ?u) = pdevs_val e (scaleR_pdevs (fst (fst Y)) (snd (fst X))) + e2"
    by blast
  let ?v = "trunc_bound_pdevs p (scaleR_pdevs (fst (fst X)) (snd (fst Y)))"
  from trunc_bound_pdevsE[OF e]
  obtain e3 where abs_e3: "¦e3¦ ≤ snd (?v)"
    and e3: "pdevs_val e (fst ?v) = pdevs_val e (scaleR_pdevs (fst (fst X)) (snd (fst Y))) + e3"
    by blast
  let ?w = "trunc_bound_pdevs p (add_pdevs (fst ?u) (fst ?v))"
  from trunc_bound_pdevsE[OF e]
  obtain e4 where abs_e4: "¦e4¦ ≤ snd (?w)"
    and e4: "pdevs_val e (fst ?w) = pdevs_val e (add_pdevs (fst ?u) (fst ?v)) + e4"
    by blast
  let ?tx = "tdev' p (snd (fst X))" and ?ty = "tdev' p (snd (fst Y))"
  let ?l = "truncate_up p (?tx * ?ty)"
  let ?ee = "truncate_up p (abs (snd X) * abs (snd Y))"
  let ?e1 = "truncate_up p (abs (snd X) * truncate_up p (¦fst (fst Y)¦ + ?ty))"
  let ?e2 = "truncate_up p (abs (snd Y) * truncate_up p (¦fst (fst X)¦ + ?tx))"

  let ?e0 = "x * y - fst (fst X) * fst (fst Y) -
      fst (fst X) * pdevs_val e (snd (fst Y)) -
      fst (fst Y) * pdevs_val e (snd (fst X))"
  let ?err = "?e0 - (e1 + e2  + e3 + e4)"
  have "abs ?err ≤ abs ?e0 + abs e1 + abs e2 + abs e3 + abs e4"
    by arith
  also have "… ≤ abs ?e0 + snd ?z0 + snd ?u + snd ?v + snd ?w"
    unfolding abs_mult
    by (auto intro!: add_mono mult_mono e abs_pdevs_val_le_tdev' abs_ge_zero abs_e1 abs_e2 abs_e3
      abs_e4 intro: tdev'_le)
  also
  have asdf: "snd (mult_aform X Y) ≤ tdev' p (snd (fst X)) * tdev' p (snd (fst Y)) + ?e1 + ?e2 + ?ee"
    by (auto simp: mult_aform_def intro!: add_mono mult_mono order_trans[OF _ tdev'] truncate_up_le)
  have "abs ?e0 ≤ ?ee + ?e1 + ?e2 + tdev' p (snd (fst X)) * tdev' p (snd (fst Y))"
    using mult_aformE[OF e x y, THEN aform_errE, THEN order_trans, OF asdf]
    by (simp add: aform_val_def mult_aform_def) arith
  also have "tdev' p (snd (fst X)) * tdev' p (snd (fst Y)) ≤ ?l"
    by (auto intro!: truncate_up_le)
  also have "?ee + ?e1 + ?e2 + ?l + snd ?z0 + snd ?u + snd ?v + snd ?w ≤
      sum_list' p [?ee, ?e1, ?e2, ?l, snd ?z0, snd ?u, snd ?v, snd ?w]"
    by (rule order_trans[OF _ sum_list_le_sum_list']) simp
  also have "… ≤ (snd (mult_aform' p X Y))"
    by (auto simp: mult_aform'_def Let_def assms split: prod.splits)
  finally have err_le: "abs ?err ≤ (snd (mult_aform' p X Y))" by arith

  show ?thesis
    apply (rule aform_errI[OF order_trans[OF _ err_le]])
    apply (subst mult_aform'_def)
    using e1 e2 e3 e4
    apply (auto simp: aform_val_def Let_def assms split: prod.splits)
    done
qed

lemma degree_aform_mult_aform':
  assumes "degree_aform_err x ≤ n"
  assumes "degree_aform_err y ≤ n"
  shows "degree_aform_err (mult_aform' p x y) ≤ n"
  using assms
  by (auto simp: mult_aform'_def Let_def trunc_bound_pdevs_def split: prod.splits
      intro!: degree_pdev_upd_le degree_trunc_pdevs_le degree_add_pdevs_le)

lemma
  fixes x a b::real
  assumes "a > 0"
  assumes "x ∈ {a ..b}"
  assumes "- inverse (b*b) ≤ alpha"
  shows inverse_linear_lower: "inverse b + alpha * (x - b) ≤ inverse x" (is ?lower)
    and inverse_linear_upper: "inverse x ≤ inverse a + alpha * (x - a)" (is ?upper)
proof -
  have deriv_inv:
    "⋀x. x ∈ {a .. b} ⟹ (inverse has_field_derivative - inverse (x*x)) (at x within {a .. b})"
    using assms
    by (auto intro!: derivative_eq_intros)
  show ?lower
    using assms
    by (intro linear_lower[OF deriv_inv])
        (auto simp: mult_mono intro!:  order_trans[OF _ assms(3)])
  show ?upper
    using assms
    by (intro linear_upper[OF deriv_inv])
        (auto simp: mult_mono intro!:  order_trans[OF _ assms(3)])
qed


subsubsection ‹Inverse›

definition inverse_aform'::"nat ⇒ real aform ⇒ real aform × real" where
  "inverse_aform' p X = (
    let l = Inf_aform' p X in
    let u = Sup_aform' p X in
    let a = min (abs l) (abs u) in
    let b = max (abs l) (abs u) in
    let sq = truncate_up p (b * b) in
    let alpha = - real_divl p 1 sq in
    let dmax = truncate_up p (real_divr p 1 a - alpha * a) in
    let dmin = truncate_down p (real_divl p 1 b - alpha * b) in
    let zeta' = truncate_up p ((dmin + dmax) / 2) in
    let zeta = if l < 0 then - zeta' else zeta' in
    let delta = truncate_up p (zeta - dmin) in
    let res1 = trunc_bound_eucl p (alpha * fst X) in
    let res2 = trunc_bound_eucl p (fst res1 + zeta) in
    let zs = trunc_bound_pdevs p (scaleR_pdevs alpha (snd X)) in
    ((fst res2, fst zs), (sum_list' p [delta, snd res1, snd res2, snd zs])))"

lemma inverse_aform'E:
  fixes X::"real aform"
  assumes e: "e ∈ UNIV → {-1 .. 1}"
  assumes Inf_pos: "Inf_aform' p X > 0"
  assumes "x = aform_val e X"
  shows "inverse x ∈ aform_err e (inverse_aform' p X)"
proof -
  define l where "l = Inf_aform' p X"
  define u where "u = Sup_aform' p X"
  define a where "a = min (abs l) (abs u)"
  define b where "b = max (abs l) (abs u)"
  define sq where "sq = truncate_up p (b * b)"
  define alpha where "alpha = - (real_divl p 1 sq)"
  define d_max' where "d_max' = truncate_up p (real_divr p 1 a - alpha * a)"
  define d_min' where "d_min' = truncate_down p (real_divl p 1 b - alpha * b)"
  define zeta where "zeta = truncate_up p ((d_min' + d_max') / 2)"
  define delta where "delta = truncate_up p (zeta - d_min')"
  note vars = l_def u_def a_def b_def sq_def alpha_def d_max'_def d_min'_def zeta_def delta_def
  let ?x = "aform_val e X"

  have "0 < l" using assms by (auto simp add: l_def Inf_aform_def)
  have "l ≤ u" by (auto simp: l_def u_def)

  hence a_def': "a = l" and b_def': "b = u" and "0 < a" "0 < b"
    using ‹0 < l› by (simp_all add: a_def b_def)
  have "0 < ?x"
    by (rule less_le_trans[OF Inf_pos order.trans[OF Inf_aform' Inf_aform], OF e])
  have "a ≤ ?x"
    by (metis order.trans Inf_aform e Inf_aform' a_def' l_def)
  have "?x ≤ b"
    by (metis order.trans Sup_aform e Sup_aform' b_def' u_def)
  hence "?x ∈ {?x .. b}"
    by simp

  have "- inverse (b * b) ≤ alpha"
    by (auto simp add: alpha_def inverse_mult_distrib[symmetric] inverse_eq_divide sq_def
      intro!: order_trans[OF real_divl] divide_left_mono truncate_up mult_pos_pos ‹0 < b›)

  {
    note ‹0 < a›
    moreover
    have "?x ∈ {a .. b}" using ‹a ≤ ?x› ‹?x ≤ b› by simp
    moreover
    note ‹- inverse (b * b) ≤ alpha›
    ultimately have "inverse ?x ≤ inverse a + alpha * (?x - a)"
      by (rule inverse_linear_upper)
    also have "… = alpha * ?x + (inverse a - alpha * a)"
      by (simp add: algebra_simps)
    also have "inverse a - (alpha * a) ≤ (real_divr p 1 a - alpha * a)"
      by (auto simp: inverse_eq_divide real_divr)
    also have "… ≤ (truncate_down p (real_divl p 1 b - alpha * b) +
          (real_divr p 1 a - alpha * a)) / 2 +
        (truncate_up p (real_divr p 1 a - alpha * a) -
          truncate_down p (real_divl p 1 b - alpha * b)) / 2"
      (is "_ ≤ (truncate_down p ?lb + ?ra) / 2 + (truncate_up p ?ra - truncate_down p ?lb) / 2")
      by (auto simp add: field_simps
        intro!: order_trans[OF _ add_left_mono[OF mult_left_mono[OF truncate_up]]])
    also have "(truncate_down p ?lb + ?ra) / 2 ≤
        truncate_up p ((truncate_down p ?lb + truncate_up p ?ra) / 2)"
      by (intro truncate_up_le divide_right_mono add_left_mono truncate_up) auto
    also
    have "(truncate_up p ?ra - truncate_down p ?lb) / 2 + truncate_down p ?lb ≤
        (truncate_up p ((truncate_down p ?lb + truncate_up p ?ra) / 2))"
      by (rule truncate_up_le) (simp add: field_simps)
    hence "(truncate_up p ?ra - truncate_down p ?lb) / 2 ≤ truncate_up p
        (truncate_up p ((truncate_down p ?lb + truncate_up p ?ra) / 2) - truncate_down p ?lb)"
      by (intro truncate_up_le) (simp add: field_simps)
    finally have "inverse ?x ≤ alpha * ?x + zeta + delta"
      by (auto simp: zeta_def delta_def d_min'_def d_max'_def right_diff_distrib ac_simps)
  } note upper = this

  {
    have "alpha * b + truncate_down p (real_divl p 1 b - alpha * b) ≤ inverse b"
      by (rule order_trans[OF add_left_mono[OF truncate_down]])
        (auto simp: inverse_eq_divide real_divl)
    hence "zeta + alpha * b ≤ delta + inverse b"
      by (auto simp: zeta_def delta_def d_min'_def d_max'_def right_diff_distrib
        intro!: order_trans[OF _ add_right_mono[OF truncate_up]])
    hence "alpha * ?x + zeta - delta ≤ inverse b + alpha * (?x - b)"
      by (simp add: algebra_simps)
    also
    {
      note ‹0 < aform_val e X›
      moreover
      note ‹aform_val e X ∈ {aform_val e X .. b}›
      moreover

      note ‹- inverse (b * b) ≤ alpha›
      ultimately
      have "inverse b + alpha * (aform_val e X - b) ≤ inverse (aform_val e X)"
        by (rule inverse_linear_lower)
    }
    finally have "alpha * (aform_val e X) + zeta - delta ≤ inverse (aform_val e X)" .
  } note lower = this


  have "inverse (aform_val e X) = alpha * (aform_val e X) + zeta +
      (inverse (aform_val e X) - alpha * (aform_val e X) - zeta)"
    (is "_ = _ + ?linerr")
    by simp
  also
  have "?linerr ∈ {- delta .. delta}"
    using lower upper by simp
  hence linerr_le: "abs ?linerr ≤ delta"
    by auto

  let ?z0 = "trunc_bound_eucl p (alpha * fst X)"
  from trunc_bound_euclE
  obtain e1 where abs_e1: "¦e1¦ ≤ snd ?z0" and e1: "fst ?z0 = alpha * fst X + e1"
    by blast
  let ?z1 = "trunc_bound_eucl p (fst ?z0 + zeta)"
  from trunc_bound_euclE
  obtain e1' where abs_e1': "¦e1'¦ ≤ snd ?z1" and e1': "fst ?z1 = fst ?z0 + zeta + e1'"
    by blast

  let ?zs = "trunc_bound_pdevs p (scaleR_pdevs alpha (snd X))"
  from trunc_bound_pdevsE[OF e]
  obtain e2 where abs_e2: "¦e2¦ ≤ snd (?zs)"
    and e2: "pdevs_val e (fst ?zs) = pdevs_val e (scaleR_pdevs alpha (snd X)) + e2"
    by blast

  have "alpha * (aform_val e X) + zeta =
      aform_val e (fst (inverse_aform' p X)) + (- e1 - e1' - e2)"
    unfolding inverse_aform'_def Let_def vars[symmetric]
    using ‹0 < l›
    by (simp add: aform_val_def assms e1') (simp add: e1 e2 algebra_simps)
  also
  let ?err = "(- e1 - e1' - e2 + inverse (aform_val e X) - alpha * aform_val e X - zeta)"
  {
    have "abs ?err ≤ abs ?linerr + abs e1 + abs e1' + abs e2"
      by simp
    also have "… ≤ delta + snd ?z0 + snd ?z1 + snd ?zs"
      by (blast intro: add_mono linerr_le abs_e1 abs_e1' abs_e2)
    also have "… ≤ (snd (inverse_aform' p X))"
      unfolding inverse_aform'_def Let_def vars[symmetric]
      using ‹0 < l›
      by (auto simp add: inverse_aform'_def pdevs_apply_trunc_pdevs assms vars[symmetric]
        intro!: order.trans[OF _ sum_list'_sum_list_le])
    finally have "abs ?err ≤ snd (inverse_aform' p X)" by simp
  } note err_le = this
  have "aform_val (e) (fst (inverse_aform' p X)) + (- e1 - e1' - e2) +
    (inverse (aform_val e X) - alpha * aform_val e X - zeta) =
    aform_val e (fst (inverse_aform' p X)) + ?err"
    by simp
  finally
  show ?thesis
    apply (intro aform_errI)
    using err_le
    by (auto simp: assms)
qed

definition "inverse_aform p a =
  do {
    let l = Inf_aform' p a;
    let u = Sup_aform' p a;
    if (l ≤ 0 ∧ 0 ≤ u) then None
    else if (l ≤ 0) then (Some (apfst uminus_aform (inverse_aform' p (uminus_aform a))))
    else Some (inverse_aform' p a)
  }"

lemma eucl_truncate_up_eq_eucl_truncate_down:
  "eucl_truncate_up p x = - (eucl_truncate_down p (- x))"
  by (auto simp: eucl_truncate_up_def eucl_truncate_down_def truncate_up_eq_truncate_down sum_negf)

lemma inverse_aformE:
  fixes X::"real aform"
  assumes e: "e ∈ UNIV → {-1 .. 1}"
    and disj: "Inf_aform' p X > 0 ∨ Sup_aform' p X < 0"
  obtains Y where
    "inverse_aform p X = Some Y"
    "inverse (aform_val e X) ∈ aform_err e Y"
proof -
  {
    assume neg: "Sup_aform' p X < 0"
    from neg have [simp]: "Inf_aform' p X ≤ 0"
      by (metis Inf_aform'_le_Sup_aform' dual_order.strict_trans1 less_asym not_less)
    from neg disj have "0 < Inf_aform' p (uminus_aform X)"
      by (auto simp: Inf_aform'_def Sup_aform'_def eucl_truncate_up_eq_eucl_truncate_down ac_simps)
    from inverse_aform'E[OF e(1) this]
    have iin: "inverse (aform_val e (uminus_aform X)) ∈ aform_err e (inverse_aform' p (uminus_aform X))"
      by simp
    let ?Y = "apfst uminus_aform (inverse_aform' p (uminus_aform X))"
    have "inverse_aform p X = Some ?Y"
      "inverse (aform_val e X) ∈ aform_err e ?Y"
      using neg iin by (auto simp: inverse_aform_def aform_err_def)
    then have ?thesis ..
  } moreover {
    assume pos: "Inf_aform' p X > 0"
    from pos have eq: "inverse_aform p X = Some (inverse_aform' p X)"
      by (auto simp: inverse_aform_def)
    moreover
    from inverse_aform'E[OF e(1) pos refl]
    have "inverse (aform_val e X) ∈ aform_err e (inverse_aform' p X)" .
    ultimately have ?thesis ..
  } ultimately show ?thesis
    using assms by auto
qed

definition aform_err_to_aform::"aform_err ⇒ nat ⇒ real aform"
  where "aform_err_to_aform X n = (fst (fst X),  pdev_upd (snd (fst X)) n (snd X))"

lemma aform_err_to_aformE:
  assumes "x ∈ aform_err e X"
  assumes deg: "degree_aform_err X ≤ n"
  obtains err where "x = aform_val (e(n:=err)) (aform_err_to_aform X n)"
    "-1 ≤ err" "err ≤ 1"
proof -
  from aform_errE[OF assms(1)] have "¦x - aform_val e (fst X)¦ ≤ snd X" by auto
  from error_absE[OF this] obtain err where err:
    "x - aform_val e (fst X) = err * snd X" "err ∈ {- 1..1}"
    by auto
  have "x = aform_val (e(n:=err)) (aform_err_to_aform X n)"
    "-1 ≤ err" "err ≤ 1"
    using err deg
    by (auto simp: aform_val_def aform_err_to_aform_def)
  then show ?thesis ..
qed

definition aform_to_aform_err::"real aform ⇒ nat ⇒ aform_err"
  where "aform_to_aform_err X n = ((fst X,  pdev_upd (snd X) n 0), abs (pdevs_apply (snd X) n))"

lemma aform_to_aform_err: "aform_val e X ∈ aform_err e (aform_to_aform_err X n)"
  if "e ∈ UNIV → {-1 .. 1}"
proof -
  from that have abs_e[simp]: "⋀i. ¦e i¦ ≤ 1" by (auto simp: abs_real_def)
  have "- e n * pdevs_apply (snd X) n ≤ ¦pdevs_apply (snd X) n¦"
  proof -
    have "- e n * pdevs_apply (snd X) n ≤ ¦- e n * pdevs_apply (snd X) n¦"
      by auto
    also have "… ≤ abs (pdevs_apply (snd X) n)"
      using that
      by (auto simp: abs_mult intro!: mult_left_le_one_le)
    finally show ?thesis .
  qed
  moreover have "e n * pdevs_apply (snd X) n ≤ ¦pdevs_apply (snd X) n¦"
  proof -
    have "e n * pdevs_apply (snd X) n ≤ ¦e n * pdevs_apply (snd X) n¦"
      by auto
    also have "… ≤ abs (pdevs_apply (snd X) n)"
      using that
      by (auto simp: abs_mult intro!: mult_left_le_one_le)
    finally show ?thesis .
  qed
  ultimately
  show ?thesis
    by (auto simp: aform_to_aform_err_def aform_err_def aform_val_def)
qed

definition "acc_err p x e ≡ (fst x, truncate_up p (snd x + e))"

definition ivl_err :: "real interval ⇒ (real × real pdevs) × real"
  where "ivl_err ivl ≡ (((upper ivl + lower ivl)/2, zero_pdevs::real pdevs), (upper ivl - lower ivl) / 2)"

lemma inverse_aform:
  fixes X::"real aform"
  assumes e: "e ∈ UNIV → {-1 .. 1}"
  assumes "inverse_aform p X = Some Y"
  shows "inverse (aform_val e X) ∈ aform_err e Y"
proof -
  from assms have "Inf_aform' p X > 0 ∨ 0 > Sup_aform' p X"
    by (auto simp: inverse_aform_def Let_def bind_eq_Some_conv split: if_splits)
  from inverse_aformE[OF e this] obtain Y where
    "inverse_aform p X = Some Y" "inverse (aform_val e X) ∈ aform_err e Y"
    by auto
  with assms show ?thesis by auto
qed

lemma aform_err_acc_err_leI:
  "fx ∈ aform_err e (acc_err p X err)"
  if "aform_val e (fst X) - (snd X + err) ≤ fx" "fx ≤ aform_val e (fst X) + (snd X + err)"
  using truncate_up[of "(snd X + err)" p] truncate_down[of p "(snd X + err)"] that
  by (auto simp: aform_err_def acc_err_def)

lemma aform_err_acc_errI:
  "fx ∈ aform_err e (acc_err p X err)"
  if "fx ∈ aform_err e (fst X, snd X + err)"
  using truncate_up[of "(snd X + err)" p] truncate_down[of p "(snd X + err)"] that
  by (auto simp: aform_err_def acc_err_def)

lemma minus_times_le_abs: "- (err * B) ≤ ¦B¦" if "-1 ≤ err" "err ≤ 1" for err::real
proof -
  have [simp]: "abs err ≤ 1" using that by (auto simp: )
  have "- (err * B) ≤ abs (- err * B)" by auto
  also have "… ≤ abs B"
    by (auto simp: abs_mult intro!: mult_left_le_one_le)
  finally show ?thesis by simp
qed

lemma times_le_abs: "err * B ≤ ¦B¦" if "-1 ≤ err" "err ≤ 1" for err::real
proof -
  have [simp]: "abs err ≤ 1" using that by (auto simp: )
  have "err * B ≤ abs (err * B)" by auto
  also have "… ≤ abs B"
    by (auto simp: abs_mult intro!: mult_left_le_one_le)
  finally show ?thesis by simp
qed

lemma aform_err_lemma1: "- 1 ≤ err ⟹ err ≤ 1 ⟹
  X1 + (A - e d * B + err * B) - e1 ≤ x ⟹
  X1 + (A - e d * B) - truncate_up p (¦B¦ + e1) ≤ x"
  apply (rule order_trans)
   apply (rule diff_mono)
    apply (rule order_refl)
   apply (rule truncate_up_le[where x="e1 - err * B"])
  by (auto simp: minus_times_le_abs)
  
lemma aform_err_lemma2: "- 1 ≤ err ⟹ err ≤ 1 ⟹
    x ≤ X1 + (A - e d * B + err * B) + e1 ⟹
    x ≤ X1 + (A - e d * B) + truncate_up p (¦B¦ + e1)"
  apply (rule order_trans[rotated])
   apply (rule add_mono)
    apply (rule order_refl)
   apply (rule truncate_up_le[where x="e1 + err * B"])
  by (auto simp: times_le_abs)

lemma aform_err_acc_err_aform_to_aform_errI:
  "x ∈ aform_err e (acc_err p (aform_to_aform_err X1 d) e1)"
  if "-1 ≤ err" "err ≤ 1" "x ∈ aform_err (e(d := err)) (X1, e1)"
  using that
  by (auto simp: acc_err_def aform_err_def aform_val_def aform_to_aform_err_def
      aform_err_to_aform_def aform_err_lemma1 aform_err_lemma2)

definition "map_aform_err I p X =
  (do {
    let X0 = aform_err_to_aform X (degree_aform_err X);
    (X1, e1) ← I X0;
    Some (acc_err p (aform_to_aform_err X1 (degree_aform_err X)) e1)
  })"

lemma map_aform_err:
  "i x ∈ aform_err e Y"
  if I: "⋀e X Y. e ∈ UNIV → {-1 .. 1} ⟹ I X = Some Y ⟹ i (aform_val e X) ∈ aform_err e Y"
  and e: "e ∈ UNIV → {-1 .. 1}"
  and Y: "map_aform_err I p X = Some Y"
  and x: "x ∈ aform_err e X"
proof -
  obtain X1 e1 where
    X1: "(I (aform_err_to_aform X (degree_aform_err X))) = Some (X1, e1)"
    and Y: "Y = acc_err p (aform_to_aform_err X1 (degree_aform (fst X))) e1"
    using Y by (auto simp: map_aform_err_def bind_eq_Some_conv Let_def)
  from aform_err_to_aformE[OF x] obtain err where
    err: "x = aform_val (e(degree_aform_err X := err)) (aform_err_to_aform X  (degree_aform_err X)) "
    (is "_ = aform_val ?e _")
    and "- 1 ≤ err" "err ≤ 1"
    by auto
  then have e': "?e ∈ UNIV → {-1 .. 1}" using e by auto
  from err have "i x =
      i (aform_val (e(degree_aform_err X := err)) (aform_err_to_aform X  (degree_aform_err X)))"
    by simp
  also note I[OF e' X1]
  also have "aform_err (e(degree_aform_err X := err)) (X1, e1) ⊆ aform_err e Y"
    apply rule
    unfolding Y using ‹-1 ≤ err› ‹err ≤ 1›
    by (rule aform_err_acc_err_aform_to_aform_errI)
  finally show ?thesis .
qed

definition "inverse_aform_err p X = map_aform_err (inverse_aform p) p X"

lemma inverse_aform_err:
  "inverse x ∈ aform_err e Y"
  if  e: "e ∈ UNIV → {-1 .. 1}"
  and Y: "inverse_aform_err p X = Some Y"
  and x: "x ∈ aform_err e X"
  using map_aform_err[OF inverse_aform[where p=p] e Y[unfolded inverse_aform_err_def] x]
  by auto

subsection ‹Reduction (Summarization of Coefficients)›
text ‹\label{sec:affinesummarize}›

definition "pdevs_of_centered_ivl r = (inner_scaleR_pdevs r One_pdevs)"

lemma pdevs_of_centered_ivl_eq_pdevs_of_ivl[simp]: "pdevs_of_centered_ivl r = pdevs_of_ivl (-r) r"
  by (auto simp: pdevs_of_centered_ivl_def pdevs_of_ivl_def algebra_simps intro!: pdevs_eqI)

lemma filter_pdevs_raw_nonzeros: "{i. filter_pdevs_raw s f i ≠ 0} = {i. f i ≠ 0} ∩ {x. s x (f x)}"
  by (auto simp: filter_pdevs_raw_def)

definition summarize_pdevs::
  "nat ⇒ (nat ⇒ 'a ⇒ bool) ⇒ nat ⇒ 'a::executable_euclidean_space pdevs ⇒ 'a pdevs"
  where "summarize_pdevs p I d x =
    (let t = tdev' p (filter_pdevs (-I) x)
     in msum_pdevs d (filter_pdevs I x) (pdevs_of_centered_ivl t))"

definition summarize_threshold
  where "summarize_threshold p t x y ⟷ infnorm y ≥ t * infnorm (eucl_truncate_up p (tdev' p x))"

lemma error_abs_euclE:
  fixes err::"'a::ordered_euclidean_space"
  assumes "abs err ≤ k"
  obtains e::"'a ⇒ real" where "err = (∑i∈Basis. (e i * (k ∙ i)) *⇩_R i)" "e ∈ UNIV → {-1 .. 1}"
proof atomize_elim
  {
    fix i::'a
    assume "i ∈ Basis"
    hence "abs (err ∙ i) ≤ (k ∙ i)" using assms by (auto simp add: eucl_le[where 'a='a] abs_inner)
    hence "∃e. (err  ∙ i = e * (k ∙ i)) ∧ e ∈ {-1..1}"
      by (rule error_absE) auto
  }
  then obtain e where e:
    "⋀i. i ∈ Basis ⟹ err ∙ i = e i * (k ∙ i)"
    "⋀i. i ∈ Basis ⟹ e i ∈ {-1 .. 1}"
    by metis
  have singleton: "⋀b. b ∈ Basis ⟹ (∑i∈Basis. e i * (k ∙ i) * (if i = b then 1 else 0)) =
    (∑i∈{b}. e i * (k ∙ i) * (if i = b then 1 else 0))"
    by (rule sum.mono_neutral_cong_right) auto
  show "∃e::'a⇒real. err = (∑i∈Basis. (e i * (k ∙ i)) *⇩_R i) ∧ (e ∈ UNIV → {-1..1})"
    using e
    by (auto intro!: exI[where x="λi. if i ∈ Basis then e i else 0"] euclidean_eqI[where 'a='a]
      simp: inner_sum_left inner_Basis singleton)
qed

lemma summarize_pdevsE:
  fixes x::"'a::executable_euclidean_space pdevs"
  assumes e: "e ∈ UNIV → {-1 .. 1}"
  assumes d: "degree x ≤ d"
  obtains e' where "pdevs_val e x = pdevs_val e' (summarize_pdevs p I d x)"
    "⋀i. i < d ⟹ e i = e' i"
    "e' ∈ UNIV → {-1 .. 1}"
proof atomize_elim
  have "pdevs_val e x = (∑i<degree x. e i *⇩_R pdevs_apply x i)"
    by (auto simp add: pdevs_val_sum intro!: sum.cong)
  also have "… = (∑i ∈ {..<degree x} ∩ {i. I i (pdevs_apply x i)}. e i *⇩_R pdevs_apply x i) +
    (∑i∈ {..<degree x} - {i. I i (pdevs_apply x i)}. e i *⇩_R pdevs_apply x i)"
    (is "_ = ?large + ?small")
    by (subst sum.union_disjoint[symmetric]) (auto simp: ac_simps intro!: sum.cong)
  also have "?large = pdevs_val e (filter_pdevs I x)"
    by (simp add: pdevs_val_filter_pdevs)
  also have "?small = pdevs_val e (filter_pdevs (-I) x)"
    by (simp add: pdevs_val_filter_pdevs Collect_neg_eq Diff_eq)
  also
  have "abs … ≤ tdev' p (filter_pdevs (-I) x)" (is "abs ?r ≤ ?t")
    using e by (rule abs_pdevs_val_le_tdev')
  hence "?r ∈ {-?t .. ?t}"
    by (metis abs_le_D1 abs_le_D2 atLeastAtMost_iff minus_le_iff)
  from in_ivl_affine_of_ivlE[OF this] obtain e2
    where "?r = aform_val e2 (aform_of_ivl (- ?t) ?t)"
      and e2: "e2 ∈ UNIV → {- 1..1}"
    by metis
  note this(1)
  also
  define e' where "e' i = (if i < d then e i else e2 (i - d))" for i
  hence "aform_val e2 (aform_of_ivl (- ?t) ?t) =
      pdevs_val (λi. e' (i + d)) (pdevs_of_ivl (- ?t) ?t)"
    by (auto simp: aform_of_ivl_def aform_val_def)
  also
  have "pdevs_val e (filter_pdevs I x) = pdevs_val e' (filter_pdevs I x)"
    using assms by (auto simp: e'_def pdevs_val_sum intro!: sum.cong)
  finally have "pdevs_val e x =
      pdevs_val e' (filter_pdevs I x) + pdevs_val (λi. e' (i + d)) (pdevs_of_ivl (- ?t) ?t)"
    .
  also note pdevs_val_msum_pdevs[symmetric, OF order_trans[OF degree_filter_pdevs_le d]]
  finally have "pdevs_val e x = pdevs_val e' (summarize_pdevs p I d x)"
    by (auto simp: summarize_pdevs_def Let_def)
  moreover have "e' ∈ UNIV → {-1 .. 1}" using e e2 by (auto simp: e'_def Pi_iff)
  moreover have "∀i < d. e' i = e i"
    by (auto simp: e'_def)
  ultimately show "∃e'. pdevs_val e x = pdevs_val e' (summarize_pdevs p I d x) ∧
      (∀i<d. e i = e' i) ∧ e' ∈ UNIV → {- 1..1}"
    by auto
qed

definition "summarize_pdevs_list p I d xs =
  map (λ(d, x). summarize_pdevs p (λi _. I i (pdevs_applys xs i)) d x) (zip [d..<d + length xs] xs)"

lemma filter_pdevs_cong[cong]:
  assumes "x = y"
  assumes "⋀i. i ∈ pdevs_domain y ⟹ P i (pdevs_apply x i) = Q i (pdevs_apply y i)"
  shows "filter_pdevs P x = filter_pdevs Q y"
  using assms
  by (force intro!: pdevs_eqI)

lemma summarize_pdevs_cong[cong]:
  assumes "p = q" "a = c" "b = d"
  assumes PQ: "⋀i. i ∈ pdevs_domain d ⟹ P i (pdevs_apply b i) = Q i (pdevs_apply d i)"
  shows "summarize_pdevs p P a b = summarize_pdevs q Q c d"
proof -
  have "(filter_pdevs P b) = filter_pdevs Q d"
    "(filter_pdevs (λa b. ¬ P a b) b) = filter_pdevs (λa b. ¬ Q a b) d"
    using assms
    by (auto intro!: filter_pdevs_cong)
  then show ?thesis by (auto simp add: assms summarize_pdevs_def Let_def)
qed

lemma lookup_eq_None_iff: "(Mapping.lookup M x = None) = (x ∉ Mapping.keys M)"
  by (transfer) auto

lemma lookup_eq_SomeD:
  "(Mapping.lookup M x = Some y) ⟹ (x ∈ Mapping.keys M)"
  by transfer auto

definition "domain_pdevs xs = (⋃(pdevs_domain ` (set xs)))"

definition "pdevs_mapping xs =
  (let
    D = sorted_list_of_set (domain_pdevs xs);
    M = Mapping.tabulate D (pdevs_applys xs);
    zeroes = replicate (length xs) 0
  in Mapping.lookup_default zeroes M)"

lemma pdevs_mapping_eq[simp]: "pdevs_mapping xs = pdevs_applys xs"
  unfolding pdevs_mapping_def pdevs_applys_def
  apply (auto simp: Mapping.lookup_default_def lookup_eq_None_iff domain_pdevs_def
      split: option.splits intro!: ext)
  subgoal by (auto intro!: nth_equalityI)
  subgoal apply (auto intro!: nth_equalityI dest: )
    subgoal
      apply (frule lookup_eq_SomeD)
      apply auto
      by (metis distinct_sorted_list_of_set keys_tabulate length_map lookup_eq_SomeD lookup_tabulate option.inject)
    subgoal
      apply (frule lookup_eq_SomeD)
      apply (auto simp: map_nth)
      by (metis (mono_tags, lifting) keys_tabulate
          lookup_eq_SomeD lookup_tabulate option.inject distinct_sorted_list_of_set)
    done
  done

lemma compute_summarize_pdevs_list[code]:
  "summarize_pdevs_list p I d xs =
    (let M = pdevs_mapping xs
    in map (λ(x, y). summarize_pdevs p (λi _. I i (M i)) x y) (zip [d..<d + length xs] xs))"
  unfolding summarize_pdevs_list_def pdevs_mapping_eq
  by auto

lemma
  in_centered_ivlE:
  fixes r t::real
  assumes "r ∈ {-t .. t}"
  obtains e where "e ∈ {-1 .. 1}" "r = e * t"
  using assms
  by (atomize_elim) (auto intro!: exI[where x="r / t"] simp: divide_simps)

lift_definition singleton_pdevs::"'a ⇒ 'a::real_normed_vector pdevs" is "λx i. if i = 0 then x else 0"
  by auto
lemmas [simp] = singleton_pdevs.rep_eq

lemma singleton_0[simp]: "singleton_pdevs 0 = zero_pdevs"
  by (auto intro!: pdevs_eqI)

lemma degree_singleton_pdevs[simp]: "degree (singleton_pdevs x) = (if x = 0 then 0 else Suc 0)"
  by (auto simp: intro!: degree_eqI)

lemma pdevs_val_singleton_pdevs[simp]: "pdevs_val e (singleton_pdevs x) = e 0 *⇩_R x"
  by (auto simp: pdevs_val_sum if_distrib sum.delta cong: if_cong)

lemma pdevs_of_ivl_real:
  fixes a b::real
  shows "pdevs_of_ivl a b = singleton_pdevs ((b - a) / 2)"
  by (auto simp: pdevs_of_ivl_def Basis_list_real_def intro!: pdevs_eqI)

lemma summarize_pdevs_listE:
  fixes X::"real pdevs list"
  assumes e: "e ∈ UNIV → {-1 .. 1}"
  assumes d: "degrees X ≤ d"
  obtains e' where "pdevs_vals e X = pdevs_vals e' (summarize_pdevs_list p I d X)"
    "⋀i. i < d ⟹ e i = e' i"
    "e' ∈ UNIV → {-1 .. 1}"
proof -
  let ?I = "{i. I i (pdevs_applys X i)}"
  let ?J = "λi x. I i (pdevs_applys X i)"

  have "pdevs_vals e X = map (λx. ∑i<degree x. e i *⇩_R pdevs_apply x i) X"
    using d
    by (auto simp: pdevs_vals_def
        simp del: real_scaleR_def
        intro!: pdevs_val_sum_le
        dest!: degrees_leD)
  also have "… = map (λx.
      (∑i∈{..<degree x} ∩ ?I. e i * pdevs_apply x i) +
      (∑i∈{..<degree x} - ?I. e i * pdevs_apply x i)) X"
    by (rule map_cong[OF refl], subst sum.union_disjoint[symmetric]) (auto intro!: sum.cong)
  also
  have "… = map (λx. pdevs_val e (filter_pdevs ?J x) + pdevs_val e (filter_pdevs (-?J) x)) X"
    (is "_ = map (λx. ?large x + ?small x) _")
    by (auto simp: pdevs_val_filter_pdevs Diff_eq Compl_eq)
  also have "… = map snd (zip [d..<d + length X] …)" by simp
  also have "… = map (λ(d, x). ?large x + ?small x) (zip [d..<d + length X] X)"
    (is "_ = map _ ?z")
    unfolding map_zip_map2
    by simp
  also have "… = map (λ(d', x). ?large x + ?small (snd (?z ! (d' - d)))) ?z"
    by (auto simp: in_set_zip)
  also
  let ?t = "λx. tdev' p (filter_pdevs (-?J) x)"
  let ?x = "λd'. snd (?z ! (d' - d))"
  {
    fix d' assume "d ≤ d'" "d' < d + length X"
    have "abs (?small (?x d')) ≤ ?t (?x d')"
      using ‹e ∈ _› by (rule abs_pdevs_val_le_tdev')
    then have "?small (?x d') ∈ {-?t (?x d') .. ?t (?x d')}"
      by auto
    from in_centered_ivlE[OF this] have "∃e∈{-1 .. 1}. ?small (?x d') = e * ?t (?x d')" by blast
  } then obtain e'' where e'':
    "e'' d' ∈ {-1 .. 1}"
    "?small (?x d') = e'' d' * ?t (?x d')"
    if "d' ∈ {d ..< d + length X}" for d'
    apply atomize_elim
    unfolding all_conj_distrib[symmetric] imp_conjR[symmetric]
    unfolding Ball_def[symmetric] atLeastAtMost_iff[symmetric]
    apply (rule bchoice)
    apply (auto simp: Bex_def )
    done
  define e' where "e' ≡ λi. if i < d then e i else if i < d + length X then e'' i else 0"
  have e': "e' d' ∈ {-1 .. 1}"
    "?small (?x d') = e' d' * ?t (?x d')"
    if "d' ∈ {d ..< d + length X}" for d'
    using e'' that
    by (auto simp: e'_def split: if_splits)
  then have *: "pdevs_val e (filter_pdevs (λa b. ¬ I a (pdevs_applys X a)) (?x d')) =
    e' d' * ?t (?x d')" if "d' ∈ {d ..< d + length X}" for d'
    using that
    by auto
  have "map (λ(d', x). ?large x + ?small (?x d')) ?z =
      map (λ(d', x). ?large x + e' d' * ?t (?x d')) ?z"
    apply (auto simp: in_set_zip)
    subgoal for n
      using e'(2)[of "d + n"]
      by auto
    done
  also have "… = map (λ(d', x). pdevs_val e' (summarize_pdevs p ?J d' x)) (zip [d..<d + length X] X)"
    apply (auto simp: summarize_pdevs_def pdevs_val_msum_pdevs Let_def in_set_zip)
    apply (subst pdevs_val_msum_pdevs)
    using d
     apply (auto intro!: degree_filter_pdevs_le[THEN order_trans])
    subgoal by (auto dest!: degrees_leD nth_mem)
    apply (auto simp: pdevs_of_ivl_real intro!: )
    subgoal premises prems
    proof -
      have "degree (filter_pdevs (λi x. I i (pdevs_applys X i)) (X ! n)) ≤ d" if "n < length X" for n
        using d that
        by (intro degree_filter_pdevs_le[THEN order_trans]) (simp add: degrees_leD)
      then show ?thesis
        using prems e''
        apply (intro pdevs_val_degree_cong)
         apply (auto dest!: )
        apply (auto simp: e'_def)
        apply (meson ‹⋀n. ⟦n < length X; degrees X ≤ d⟧ ⟹ degree (X ! n) ≤ d + n› degree_filter_pdevs_le less_le_trans)
        by (meson less_le_trans trans_less_add1)
    qed
    done
  also have "… = pdevs_vals e' (summarize_pdevs_list p I d X)"
    by (auto simp: summarize_pdevs_list_def pdevs_vals_def)
  finally have "pdevs_vals e X = pdevs_vals e' (summarize_pdevs_list p I d X)" .
  moreover have "(⋀i. i < d ⟹ e i = e' i)" "e' ∈ UNIV → {- 1..1}"
    using ‹e ∈ _› e''
    by (auto simp: e'_def)
  ultimately show ?thesis ..
qed

fun list_ex2 where
  "list_ex2 P [] xs = False"
| "list_ex2 P xs [] = False"
| "list_ex2 P (x#xs) (y#ys) = (P x y ∨ list_ex2 P xs ys)"

lemma list_ex2_iff:
  "list_ex2 P xs ys ⟷ (¬list_all2 (-P) (take (length ys) xs) (take (length xs) ys))"
  by (induction P xs ys rule: list_ex2.induct) auto

definition "summarize_aforms p C d (X::real aform list) =
  (zip (map fst X) (summarize_pdevs_list p (C X) d (map snd X)))"

lemma aform_vals_pdevs_vals:
  "aform_vals e X = map (λ(x, y). x + y) (zip (map fst X) (pdevs_vals e (map snd X)))"
  by (auto simp: pdevs_vals_def aform_vals_def aform_val_def[abs_def]
      map_zip_map map_zip_map2 split_beta' zip_same_conv_map)

lemma summarize_aformsE:
  fixes X::"real aform list"
  assumes e: "e ∈ UNIV → {-1 .. 1}"
  assumes d: "degree_aforms X ≤ d"
  obtains e' where "aform_vals e X = aform_vals e' (summarize_aforms p C d X)"
    "⋀i. i < d ⟹ e i = e' i"
    "e' ∈ UNIV → {-1 .. 1}"
proof -
  define Xs where "Xs = map snd X"
  have "aform_vals e X = map (λ(x, y). x + y) (zip (map fst X) (pdevs_vals e Xs))"
    by (auto simp: aform_vals_pdevs_vals Xs_def)
  also obtain e' where e': "e' ∈ UNIV → {-1 .. 1}"
    "⋀i. i < d ⟹ e i = e' i"
    "pdevs_vals e Xs = pdevs_vals e' (summarize_pdevs_list p (C X) d Xs)"
    using summarize_pdevs_listE[OF e d, of p "C X"]
    by (metis Xs_def)
  note this(3)
  also have "map (λ(x, y). x + y) (zip (map fst X) …) = aform_vals e' (summarize_aforms p C d X)"
    unfolding aform_vals_pdevs_vals
    by (simp add: summarize_aforms_def Let_def Xs_def summarize_pdevs_list_def
        split_beta')
  finally have "aform_vals e X = aform_vals e' (summarize_aforms p C d X)"
    "⋀i. i < d ⟹ e i = e' i"
    "e' ∈ UNIV → {-1 .. 1}"
    using e' d
    by (auto simp: Xs_def)
  then show ?thesis ..
qed

text ‹Different reduction strategies:›

definition "collect_threshold p ta t (X::real aform list) =
  (let
    Xs = map snd X;
    as = map (λX. max ta (t * tdev' p X)) Xs
  in (λ(i::nat) xs. list_ex2 (≤) as (map abs xs)))"

definition "collect_girard p m (X::real aform list) =
  (let
    Xs = map snd X;
    M = pdevs_mapping Xs;
    D = domain_pdevs Xs;
    N = length X
  in if card D ≤ m then (λ_ _. True) else
    let
      Ds = sorted_list_of_set D;
      ortho_indices = map fst (take (2 * N) (sort_key (λ(i, r). r) (map (λi. let xs = M i in (i, sum_list' p xs - fold max xs 0)) Ds)));
      _ = ()
    in (λi (xs::real list). i ∈ set ortho_indices))"



subsection ‹Splitting with heuristics›

definition "abs_pdevs = unop_pdevs abs"

definition "abssum_of_pdevs_list X = fold (λa b. (add_pdevs (abs_pdevs a) b)) X zero_pdevs"

definition "split_aforms xs i = (let splits = map (λx. split_aform x i) xs in (map fst splits, map snd splits))"

definition "split_aforms_largest_uncond X =
  (let (i, x) = max_pdev (abssum_of_pdevs_list (map snd X)) in split_aforms X i)"

definition "Inf_aform_err p Rd = (float_of (truncate_down p (Inf_aform' p (fst Rd) - abs(snd Rd))))"
definition "Sup_aform_err p Rd = (float_of (truncate_up p (Sup_aform' p (fst Rd) + abs(snd Rd))))"

context includes interval.lifting begin
lift_definition ivl_of_aform_err::"nat ⇒ aform_err ⇒ float interval"
  is "λp Rd. (Inf_aform_err p Rd, Sup_aform_err p Rd)"
  by (auto simp: aform_err_def  Inf_aform_err_def Sup_aform_err_def
      intro!: truncate_down_le truncate_up_le add_increasing[OF _ Inf_aform'_le_Sup_aform'])
lemma lower_ivl_of_aform_err: "lower (ivl_of_aform_err p Rd) = Inf_aform_err p Rd"
  and upper_ivl_of_aform_err: "upper (ivl_of_aform_err p Rd) = Sup_aform_err p Rd"
  by (transfer, simp)+
end

definition approx_un::"nat
     ⇒ (float interval ⇒ float interval option)
        ⇒ ((real × real pdevs) × real) option
           ⇒ ((real × real pdevs) × real) option"
  where "approx_un p f a = do {
  rd ← a;
  ivl ← f (ivl_of_aform_err p rd);
  Some (ivl_err (real_interval ivl))
}"

definition interval_extension1::"(float interval ⇒ (float interval) option) ⇒ (real ⇒ real) ⇒ bool"
  where "interval_extension1 F f ⟷ (∀ivl ivl'. F ivl = Some ivl' ⟶ (∀x. x ∈⇩_r ivl ⟶ f x ∈⇩_r ivl'))"

lemma interval_extension1D:
  assumes "interval_extension1 F f"
  assumes "F ivl = Some ivl'"
  assumes "x ∈⇩_r ivl"
  shows "f x ∈⇩_r ivl'"
  using assms by (auto simp: interval_extension1_def)

lemma approx_un_argE:
  assumes au: "approx_un p F X = Some Y"
  obtains X' where "X = Some X'"
  using assms
  by (auto simp: approx_un_def bind_eq_Some_conv)

lemma degree_aform_independent_from:
  "degree_aform (independent_from d1 X) ≤ d1 + degree_aform X"
  by (auto simp: independent_from_def degree_msum_pdevs_le)

lemma degree_aform_of_ivl:
  fixes a b::"'a::executable_euclidean_space"
  shows "degree_aform (aform_of_ivl a b) ≤ length (Basis_list::'a list)"
  by (auto simp: aform_of_ivl_def degree_pdevs_of_ivl_le)

lemma aform_err_ivl_err[simp]: "aform_err e (ivl_err ivl') = set_of ivl'"
  by (auto simp: aform_err_def ivl_err_def aform_val_def divide_simps set_of_eq)

lemma Inf_Sup_aform_err:
  fixes X
  assumes e: "e ∈ UNIV → {-1 .. 1}"
  defines "X' ≡ fst X"
  shows "aform_err e X ⊆ {Inf_aform_err p X .. Sup_aform_err p X}"
  using Inf_aform[OF e, of X'] Sup_aform[OF e, of X'] Inf_aform'[of p X'] Sup_aform'[of X' p]
  by (auto simp: aform_err_def X'_def Inf_aform_err_def Sup_aform_err_def
      intro!: truncate_down_le truncate_up_le)

lemma ivl_of_aform_err:
  fixes X
  assumes e: "e ∈ UNIV → {-1 .. 1}"
  shows "x ∈ aform_err e X ⟹ x ∈⇩_r ivl_of_aform_err p X"
  using Inf_Sup_aform_err[OF e, of X p]
  by (auto simp: set_of_eq lower_ivl_of_aform_err upper_ivl_of_aform_err)

lemma approx_unE:
  assumes ie: "interval_extension1 F f"
  assumes e: "e ∈ UNIV → {-1 .. 1}"
  assumes au: "approx_un p F X'err = Some Ye"
  assumes x: "case X'err of None ⇒ True | Some X'err ⇒ x ∈ aform_err e X'err"
  shows "f x ∈ aform_err e Ye"
proof -
  from au obtain ivl' X' err
    where F: "F (ivl_of_aform_err p (X', err)) = Some (ivl')"
      and Y: "Ye = ivl_err (real_interval ivl')"
     and X'err: "X'err = Some (X', err)"
    by (auto simp: approx_un_def bind_eq_Some_conv)

  from x
  have "x ∈ aform_err e (X', err)" by (auto simp: X'err)
  from ivl_of_aform_err[OF e this]
  have "x ∈⇩_r ivl_of_aform_err p (X', err)" .
  from interval_extension1D[OF ie F this]
  have "f x ∈⇩_r ivl'" .
  also have "… = aform_err e Ye"
    unfolding Y aform_err_ivl_err ..
  finally show ?thesis .
qed

definition "approx_bin p f rd sd = do {
  ivl ← f (ivl_of_aform_err p rd)
             (ivl_of_aform_err p sd);
  Some (ivl_err (real_interval ivl))
}"

definition interval_extension2::"(float interval ⇒ float interval ⇒ float interval option) ⇒ (real ⇒ real ⇒ real) ⇒ bool"
  where "interval_extension2 F f ⟷ (∀ivl1 ivl2 ivl. F ivl1 ivl2 = Some ivl ⟶
    (∀x y. x ∈⇩_r ivl1 ⟶ y ∈⇩_r ivl2 ⟶ f x y ∈⇩_r ivl))"

lemma interval_extension2D:
  assumes "interval_extension2 F f"
  assumes "F ivl1 ivl2 = Some ivl"
  shows "x ∈⇩_r ivl1 ⟹ y ∈⇩_r ivl2 ⟹ f x y ∈⇩_r ivl"
  using assms by (auto simp: interval_extension2_def)

lemma approx_binE:
  assumes ie: "interval_extension2 F f"
  assumes w: "w ∈ aform_err e (W', errw)"
  assumes x: "x ∈ aform_err e (X', errx)"
  assumes ab: "approx_bin p F ((W', errw)) ((X', errx)) = Some Ye"
  assumes e: "e ∈ UNIV → {-1 .. 1}"
  shows "f w x ∈ aform_err e Ye"
proof -
  from ab obtain ivl'
    where F: "F (ivl_of_aform_err p (W', errw)) (ivl_of_aform_err p (X', errx)) = Some ivl'"
      and Y: "Ye = ivl_err (real_interval ivl')"
    by (auto simp: approx_bin_def bind_eq_Some_conv max_def)
  from interval_extension2D[OF ie F
        ivl_of_aform_err[OF e, where p=p, OF w]
        ivl_of_aform_err[OF e, where p=p, OF x]]
  have "f w x ∈⇩_r ivl'" .
  also have "… = aform_err e Ye" unfolding Y aform_err_ivl_err ..
  finally show ?thesis .
qed

definition "min_aform_err p a1 (a2::aform_err) =
  (let
    ivl1 = ivl_of_aform_err p a1;
    ivl2 = ivl_of_aform_err p a2
  in if upper ivl1 < lower ivl2 then a1
      else if upper ivl2 < lower ivl1 then a2
      else ivl_err (real_interval (min_interval ivl1 ivl2)))"

definition "max_aform_err p a1 (a2::aform_err) =
  (let
    ivl1 = ivl_of_aform_err p a1;
    ivl2 = ivl_of_aform_err p a2
  in if upper ivl1 < lower ivl2 then a2
      else if upper ivl2 < lower ivl1 then a1
      else ivl_err (real_interval (max_interval ivl1 ivl2)))"


subsection ‹Approximate Min Range - Kind Of Trigonometric Functions›

definition affine_unop :: "nat ⇒ real ⇒ real ⇒ real ⇒ aform_err ⇒ aform_err" where
"affine_unop p a b d X = (let
    ((x, xs), xe) = X;
    (ax, axe) = trunc_bound_eucl p (a * x);
    (y, ye) = trunc_bound_eucl p (ax + b);
    (ys, yse) = trunc_bound_pdevs p (scaleR_pdevs a xs)
    in ((y, ys), sum_list' p [truncate_up p (¦a¦ * xe), axe, ye, yse, d]))"
  ― ‹TODO: also do binop›

lemma aform_err_leI:
  "y ∈ aform_err e (c, d)"
  if "y ∈ aform_err e (c, d')" "d' ≤ d"
  using that by (auto simp: aform_err_def)

lemma aform_err_eqI:
  "y ∈ aform_err e (c, d)"
  if "y ∈ aform_err e (c, d')" "d' = d"
  using that by (auto simp: aform_err_def)

lemma sum_list'_append[simp]: "sum_list' p (ds@[d]) = truncate_up p (d + sum_list' p ds)"
  unfolding sum_list'_def
  by (simp add: eucl_truncate_up_real_def)

lemma aform_err_sum_list':
  "y ∈ aform_err e (c, sum_list' p ds)"
  if "y ∈ aform_err e (c, sum_list ds)"
  using that(1)
  apply (rule aform_err_leI)
  by (rule sum_list_le_sum_list')

lemma aform_err_trunc_bound_eucl:
  "y ∈ aform_err e ((fst (trunc_bound_eucl p X), xs), snd (trunc_bound_eucl p X) + d)"
  if y: "y ∈ aform_err e ((X, xs), d)"
  using that
proof -
  from aform_errE[OF y]
  have "¦y - aform_val e (X, xs)¦ ≤ d" by auto
  then show ?thesis
    apply (intro aform_errI)
    apply (rule trunc_bound_euclE[of p X])
    by (auto simp: aform_val_def)
qed

lemma trunc_err_pdevsE:
  assumes "e ∈ UNIV → {-1 .. 1}"
  obtains err where
  "¦err¦ ≤ tdev' p (trunc_err_pdevs p xs)"
  "pdevs_val e (trunc_pdevs p xs) = pdevs_val e xs + err"
  using trunc_bound_pdevsE[of e p xs]
  by (auto simp: trunc_bound_pdevs_def assms)

lemma aform_err_trunc_bound_pdevsI:
  "y ∈ aform_err e ((c, fst (trunc_bound_pdevs p xs)), snd (trunc_bound_pdevs p xs) + d)"
  if y: "y ∈ aform_err e ((c, xs), d)"
  and e: "e ∈ UNIV → {-1 .. 1}"
  using that
proof -
  define exs where "exs = trunc_err_pdevs p xs"
  from aform_errE[OF y]
  have "¦y - aform_val e (c, xs)¦ ≤ d" by auto
  then show ?thesis
    apply (intro aform_errI)
    apply (rule trunc_err_pdevsE[OF e, of p xs])
    by (auto simp: aform_val_def trunc_bound_pdevs_def)
qed

lemma aform_err_addI:
  "y ∈ aform_err e ((a + b, xs), d)"
  if "y - b ∈ aform_err e ((a, xs), d)"
  using that
  by (auto simp: aform_err_def aform_val_def)

theorem affine_unop:
  assumes x: "x ∈ aform_err e X"
  assumes f: "¦f x - (a * x + b)¦ ≤ d"
    and e: "e ∈ UNIV → {-1 .. 1}"
  shows "f x ∈ aform_err e (affine_unop p a b d X)"
proof -
  show ?thesis
    unfolding affine_unop_def Let_def
    apply (auto simp: split_beta')
    apply (rule aform_err_sum_list')
    apply simp
    apply (rule aform_err_eqI)
     apply (rule aform_err_trunc_bound_eucl)
     apply (rule aform_err_addI)
     apply (rule aform_err_trunc_bound_eucl)
     apply (rule aform_err_trunc_bound_pdevsI)
    using e
      apply auto
    apply (rule aform_errI)
    apply (auto simp: aform_val_def)
  proof -
    define x' where "x' = (fst (fst X) + pdevs_val e (snd (fst X)))"
    have x_x': "¦x - x'¦ ≤ snd X"
      using aform_errE[OF x]
      by (auto simp: x'_def aform_val_def)
    have "¦f x - b - (a * fst (fst X) + a * pdevs_val e (snd (fst X)))¦ =
      ¦f x - (a * x + b) + a * (x - x')¦"
      by (simp add: algebra_simps x'_def)
    also have "… ≤ ¦f x - (a * x + b)¦ + ¦a * (x - x')¦"
      by (rule abs_triangle_ineq)
    also note f
    also have "¦a * (x - x')¦ ≤ truncate_up p (¦a¦ * snd X)"
      by (rule truncate_up_le)
        (auto simp: abs_mult intro!: mult_left_mono x_x')
    finally show "¦f x - b - (a * fst (fst X) + a * pdevs_val e (snd (fst X)))¦ ≤
        truncate_up p (¦a¦ * snd X) + d"
      by auto
  qed
qed

lemma min_range_coeffs_ge:
  "¦f x - (a * x + b)¦ ≤ d"
  if l: "l ≤ x" and u: "x ≤ u"
    and f': "⋀y. y ∈ {l .. u} ⟹ (f has_real_derivative f' y) (at y)"
    and a: "⋀y. y ∈ {l..u} ⟹ a ≤ f' y"
    and d: "d ≥ (f u - f l - a * (u - l)) / 2 + ¦(f l + f u - a * (l + u)) / 2 - b¦"
  for a b d::real
proof (rule order_trans[OF _ d])
  note f'_at = has_field_derivative_at_within[OF f']
  from l u have lu: "x ∈ {l .. u}" and llu: "l ∈ {l .. u}" by simp_all

  define m where "m = (f l + f u - a * (l + u)) / 2"
  have "¦f x - (a * x + b)¦ = ¦f x - (a * x + m) + (m - b)¦" by (simp add: algebra_simps)
  also have "… ≤ ¦f x - (a * x + m)¦ + ¦m - b¦" by (rule abs_triangle_ineq)
  also have "¦f x - (a * x + m)¦ ≤ (f u - f l - a * (u - l)) / 2"
  proof (rule abs_leI)
    have "f x ≥ f l + a * (x - l)" (is "?l ≥ ?r")
      apply (rule order_trans) prefer 2
       apply (rule linear_lower2[OF f'_at, of l u a])
      subgoal by assumption
      subgoal by (rule a)
      subgoal
        using lu
        by (auto intro!: mult_right_mono)
      subgoal using lu by auto
      done
    also have "a * x + m - (f u - f l - a * (u - l)) / 2 ≤ ?r"
      by (simp add: algebra_simps m_def field_simps)
    finally (xtrans) show "- (f x - (a * x + m)) ≤ (f u - f l - a * (u - l)) / 2"
      by (simp add: algebra_simps m_def divide_simps)
  next
    have "f x ≤ f u + a * (x - u)"
      apply (rule order_trans)
       apply (rule linear_upper2[OF f'_at, of l u a])
      subgoal by assumption
      subgoal by (rule a)
      subgoal
        using lu
        by (auto intro!: mult_right_mono)
      subgoal using lu by auto
      done
    also have "… ≤ a * x + m + (f u - f l - a * (u - l)) / 2"
      by (simp add: m_def divide_simps algebra_simps)
    finally show "f x - (a * x + m) ≤ (f u - f l - a * (u - l)) / 2"
      by (simp add: algebra_simps m_def divide_simps)
  qed
  also have "¦m - b¦ = abs ((f l + f u - a * (l + u)) / 2 - b)"
    unfolding m_def ..
  finally show "¦f x - (a * x + b)¦ ≤ (f u - f l - a * (u - l)) / 2 + ¦(f l + f u - a * (l + u)) / 2 - b¦"
    by (simp)
qed

lemma min_range_coeffs_le:
  "¦f x - (a * x + b)¦ ≤ d"
  if l: "l ≤ x" and u: "x ≤ u"
    and f': "⋀y. y ∈ {l .. u} ⟹ (f has_real_derivative f' y) (at y)"
    and a: "⋀y. y ∈ {l .. u} ⟹ f' y ≤ a"
    and d: "d ≥ (f l - f u + a * (u - l)) / 2 + ¦(f l + f u - a * (l + u)) / 2 - b¦"
  for a b d::real
proof (rule order_trans[OF _ d])
  note f'_at = has_field_derivative_at_within[OF f']
  from l u have lu: "x ∈ {l .. u}" and llu: "l ∈ {l .. u}" by simp_all

  define m where "m = (f l + f u - a * (l + u)) / 2"
  have "¦f x - (a * x + b)¦ = ¦f x - (a * x + m) + (m - b)¦" by (simp add: algebra_simps)
  also have "… ≤ ¦f x - (a * x + m)¦ + ¦m - b¦" by (rule abs_triangle_ineq)
  also have "¦f x - (a * x + m)¦ ≤ (f l - f u + a * (u - l)) / 2"
  proof (rule abs_leI)
    have "f x ≥ f u + a * (x - u)" (is "?l ≥ ?r")
      apply (rule order_trans) prefer 2
       apply (rule linear_lower[OF f'_at, of l u a])
      subgoal by assumption
      subgoal by (rule a)
      subgoal
        using lu
        by (auto intro!: mult_right_mono)
      subgoal using lu by auto
      done
    also have "a * x + m - (f l - f u + a * (u - l)) / 2 ≤ ?r"
      using lu
      by (auto simp add: algebra_simps m_def field_simps intro!: mult_left_mono_neg)
    finally (xtrans) show "- (f x - (a * x + m)) ≤ (f l - f u + a * (u - l)) / 2"
      by (simp add: algebra_simps m_def divide_simps)
  next
    have "f x ≤ f l + a * (x - l)"
      apply (rule order_trans)
       apply (rule linear_upper[OF f'_at, of l u a])
      subgoal by assumption
      subgoal by (rule a)
      subgoal
        using lu
        by (auto intro!: mult_right_mono)
      subgoal using lu by auto
      done
    also have "… ≤ a * x + m + (f l - f u + a * (u - l)) / 2"
      using lu
      by (auto simp add: algebra_simps m_def field_simps intro!: mult_left_mono_neg)
    finally show "f x - (a * x + m) ≤ (f l - f u + a * (u - l)) / 2"
      by (simp add: algebra_simps m_def divide_simps)
  qed
  also have "¦m - b¦ = abs ((f l + f u - a * (l + u)) / 2 - b)"
    unfolding m_def ..
  finally show "¦f x - (a * x + b)¦ ≤ (f l - f u + a * (u - l)) / 2 + ¦(f l + f u - a * (l + u)) / 2 - b¦"
    by (simp)
qed

context includes floatarith_notation begin

definition "range_reducer p l =
  (if l < 0 ∨ l > 2 * lb_pi p
  then approx p (Pi * (Num (-2)) * (Floor (Num (l * Float 1 (-1)) / Pi))) []
  else Some 0)"

lemmas approx_emptyD = approx[OF bounded_by_None[of Nil], simplified]

lemma range_reducerE:
  assumes "range_reducer p l = Some ivl"
  obtains n::int where "n * (2 * pi) ∈⇩_r ivl"
proof (cases "l ≥ 0 ∧ l ≤ 2 * lb_pi p")
  case False
  with assms have "- ⌊l / (2 * pi)⌋ * (2 * pi) ∈⇩_r ivl"
    by (auto simp: range_reducer_def bind_eq_Some_conv inverse_eq_divide
        algebra_simps dest!: approx_emptyD)
  then show ?thesis ..
next
  case True then have "real_of_int 0 * (2 * pi) ∈⇩_r ivl" using assms
    by (auto simp: range_reducer_def zero_in_float_intervalI)
  then show ?thesis ..
qed

definition "range_reduce_aform_err p X = do {
  r ← range_reducer p (lower (ivl_of_aform_err p X));
  Some (add_aform' p X (ivl_err (real_interval r)))
}"

lemma range_reduce_aform_errE:
  assumes e: "e ∈ UNIV → {-1 .. 1}"
  assumes x: "x ∈ aform_err e X"
  assumes "range_reduce_aform_err p X = Some Y"
  obtains n::int where "x + n * (2 * pi) ∈ aform_err e Y"
proof -
  from assms obtain r
    where x: "x ∈ aform_err e X"
     and r: "range_reducer p (lower (ivl_of_aform_err p X)) = Some r"
     and Y:  "Y = add_aform' p X (ivl_err (real_interval r))"
    by (auto simp: range_reduce_aform_err_def bind_eq_Some_conv mid_err_def split: prod.splits)
  from range_reducerE[OF r]
  obtain n::int where "n * (2 * pi) ∈⇩_r r"
    by auto
  then have "n * (2 * pi) ∈ aform_err e (ivl_err (real_interval r))"
    by (auto simp: aform_val_def ac_simps divide_simps abs_real_def set_of_eq intro!: aform_errI)
  from add_aform'[OF e x this, of p]
  have "x + n * (2 * pi) ∈ aform_err e Y"
    by (auto simp: Y)
  then show ?thesis ..
qed

definition "min_range_mono p F DF l u X = do {
  let L = Num l;
  let U = Num u;
  aivl ← approx p (Min (DF L) (DF U)) [];
  let a = lower aivl;
  let A = Num a;
  bivl ← approx p (Half (F L + F U - A * (L + U))) [];
  let (b, be) = mid_err bivl;
  let (B, Be) = (Num (float_of b), Num (float_of be));
  divl ← approx p ((Half (F U - F L - A * (U - L))) + Be) [];
  Some (affine_unop p a b (real_of_float (upper divl)) X)
}"

lemma min_range_mono:
  assumes x: "x ∈ aform_err e X"
  assumes "l ≤ x" "x ≤ u"
  assumes "min_range_mono p F DF l u X = Some Y"
  assumes e: "e ∈ UNIV → {-1 .. 1}"
  assumes F: "⋀x. x ∈ {real_of_float l .. u} ⟹ interpret_floatarith (F (Num x)) [] = f x"
  assumes DF: "⋀x. x ∈ {real_of_float l .. u} ⟹ interpret_floatarith (DF (Num x)) [] = f' x"
  assumes f': "⋀x. x ∈ {real_of_float l .. u} ⟹ (f has_real_derivative f' x) (at x)"
  assumes f'_le: "⋀x. x ∈ {real_of_float l .. u} ⟹ min (f' l) (f' u) ≤ f' x"
  shows "f x ∈ aform_err e Y"
proof -
  from assms obtain a b be bivl divl
    where bivl: "(f l + f u - a * (l + u))/2 ∈⇩_r bivl"
      and Y: "Y = affine_unop p a b (upper divl) X"
      and du: "(f u - f l - a * (u - l)) / 2 + be ∈⇩_r divl"
      and a: "a ≤ f' l" "a ≤ f' u"
      and b_def: "b = (lower bivl + upper bivl) / 2"
      and be_def: "be = (upper bivl - lower bivl) / 2"
    by (auto simp: min_range_mono_def Let_def bind_eq_Some_conv mid_err_def set_of_eq
        simp del: eq_divide_eq_numeral1
        split: prod.splits if_splits dest!: approx_emptyD)
  have diff_le: "real_of_float a ≤ f' y" if "real_of_float l ≤ y" "y ≤ u" for y
    using f'_le[of y] that a
    by auto
  have le_be: "¦(f (l) + f (u) - a * (real_of_float l + u)) / 2 - b¦ ≤ be"
    using bivl
    unfolding b_def be_def
    by (auto simp: abs_real_def divide_simps set_of_eq)
  have "¦f x - (a * x + b)¦ ≤ upper divl"
    apply (rule min_range_coeffs_ge)
        apply (rule ‹l ≤ x›)
       apply (rule ‹x ≤ u›)
      apply (rule f') apply assumption
    using diff_le apply force
    apply (rule order_trans[OF add_mono[OF order_refl]])
     apply (rule le_be)
    using bivl du
    unfolding b_def[symmetric] be_def[symmetric]
    by (auto simp: set_of_eq)
  from affine_unop[where f=f and p = p, OF ‹x ∈ _› this e]
  have "f x ∈ aform_err e (affine_unop p (real_of_float a) b (upper divl) X)"
    by (auto simp: Y)
  then show ?thesis
    by (simp add: Y b_def)
qed

definition "min_range_antimono p F DF l u X = do {
  let L = Num l;
  let U = Num u;
  aivl ← approx p (Max (DF L) (DF U)) [];
  let a = upper aivl;
  let A = Num a;
  bivl ← approx p (Half (F L + F U - A * (L + U))) [];
  let (b, be) = mid_err bivl;
  let (B, Be) = (Num (float_of b), Num (float_of be));
  divl ← approx p (Add (Half (F L - F U + A * (U - L))) Be) [];
  Some (affine_unop p a b (real_of_float (upper divl)) X)
}"

lemma min_range_antimono:
  assumes x: "x ∈ aform_err e X"
  assumes "l ≤ x" "x ≤ u"
  assumes "min_range_antimono p F DF l u X = Some Y"
  assumes e: "e ∈ UNIV → {-1 .. 1}"
  assumes F: "⋀x. x ∈ {real_of_float l .. u} ⟹ interpret_floatarith (F (Num x)) [] = f x"
  assumes DF: "⋀x. x ∈ {real_of_float l .. u} ⟹ interpret_floatarith (DF (Num x)) [] = f' x"
  assumes f': "⋀x. x ∈ {real_of_float l .. u} ⟹ (f has_real_derivative f' x) (at x)"
  assumes f'_le: "⋀x. x ∈ {real_of_float l .. u} ⟹ f' x ≤ max (f' l) (f' u)"
  shows "f x ∈ aform_err e Y"
proof -
  from assms obtain a b be aivl bivl divl
    where bivl: "(f l + f u - real_of_float a * (l + u)) / 2 ∈⇩_r bivl"
    and Y: "Y = affine_unop p a b (real_of_float (upper divl)) X"
    and du: "(f l - f u + a * (u - l)) / 2 + be ∈⇩_r divl"
    and a: "f' l ≤ a" "f' u ≤ a"
    and a_def: "a = upper aivl"
    and b_def: "b = (lower bivl + upper bivl) / 2"
    and be_def: "be = (upper bivl - lower bivl) / 2"
    by (auto simp: min_range_antimono_def Let_def bind_eq_Some_conv mid_err_def set_of_eq
        simp del: eq_divide_eq_numeral1
        split: prod.splits if_splits dest!: approx_emptyD)
  have diff_le: "f' y ≤ real_of_float a" if "real_of_float l ≤ y" "y ≤ u" for y
    using f'_le[of y] that a
    by auto
  have le_be: "¦(f (l) + f (u) - a * (real_of_float l + u)) / 2 - b¦ ≤ be"
    using bivl
    unfolding b_def be_def
    by (auto simp: abs_real_def divide_simps set_of_eq)
  have "¦f x - (a * x + b)¦ ≤ upper divl"
    apply (rule min_range_coeffs_le)
        apply (rule ‹l ≤ x›)
       apply (rule ‹x ≤ u›)
      apply (rule f') apply assumption
    using diff_le apply force
    apply (rule order_trans[OF add_mono[OF order_refl]])
     apply (rule le_be)
    using du bivl
    unfolding b_def[symmetric] be_def[symmetric]
    by (auto simp: set_of_eq)
  from affine_unop[where f=f and p = p, OF ‹x ∈ _› this e]
  have "f x ∈ aform_err e (affine_unop p (real_of_float a) b (upper divl) X)"
    by (auto simp: Y)
  then show ?thesis
    by (simp add: Y b_def)
qed

definition "cos_aform_err p X = do {
  X ← range_reduce_aform_err p X;
  let ivl = ivl_of_aform_err p X;
  let l = lower ivl;
  let u = upper ivl;
  let L = Num l;
  let U = Num u;
  if l ≥ 0 ∧ u ≤ lb_pi p then
   min_range_antimono p Cos (λx. (Minus (Sin x))) l u X
  else if l ≥ ub_pi p ∧ u ≤ 2 * lb_pi p then
   min_range_mono p Cos (λx. (Minus (Sin x))) l u X
  else do {
    Some (ivl_err (real_interval (cos_float_interval p ivl)))
  }
}"

lemma abs_half_enclosure:
  fixes r::real
  assumes "bl ≤ r" "r ≤ bu"
  shows "¦r - (bl + bu) / 2¦ ≤ (bu - bl) / 2"
  using assms
  by (auto simp: abs_real_def divide_simps)

lemma cos_aform_err:
  assumes x: "x ∈ aform_err e X0"
  assumes "cos_aform_err p X0 = Some Y"
  assumes e: "e ∈ UNIV → {-1 .. 1}"
  shows "cos x ∈ aform_err e Y"
proof -
  from assms obtain X ivl l u where
    X: "range_reduce_aform_err p X0 = Some X"
    and ivl_def: "ivl = ivl_of_aform_err p X"
    and l_def: "l = lower ivl"
    and u_def: "u = upper ivl"
    by (auto simp: cos_aform_err_def bind_eq_Some_conv)
  from range_reduce_aform_errE[OF e x X]
  obtain n where xn: "x + real_of_int n * (2 * pi) ∈ aform_err e X"
    by auto
  define xn where "xn = x + n * (2 * pi)"
  with xn have xn: "xn ∈ aform_err e X" by auto
  from ivl_of_aform_err[OF e xn, of p, folded ivl_def]
  have "xn ∈⇩_r ivl" .
  then have lxn: "l ≤ xn" and uxn: "xn ≤ u"
    by (auto simp: l_def u_def set_of_eq)
  consider "l ≥ 0" "u ≤ lb_pi p"
    | "l < 0 ∨ u > lb_pi p" "l ≥ ub_pi p" "u ≤ 2 * lb_pi p"
    | "l < 0 ∨ u > lb_pi p" "l < ub_pi p ∨ u > 2 * lb_pi p"
    by arith
  then show ?thesis
  proof cases
    case 1
    then have min_eq_Some: "min_range_antimono p Cos (λx. Minus (Sin x)) l u X = Some Y"
      and bounds: "0 ≤ l" "u ≤ (lb_pi p)"
      using assms(2)
      unfolding cos_aform_err_def X l_def u_def
      by (auto simp: X Let_def simp flip: l_def u_def ivl_def  split: prod.splits)
    have bounds: "0 ≤ l" "u ≤ pi" using bounds pi_boundaries[of p] by auto
    have diff_le: "- sin y ≤ max (- sin (real_of_float l)) (- sin (real_of_float u))"
      if "real_of_float l ≤ y" "y ≤ real_of_float u" for y
    proof -
      consider "y ≤ pi / 2" | "y ≥ pi / 2" by arith
      then show ?thesis
      proof cases
        case 1
        then have "- sin y ≤ - sin l"
          using that bounds
          by (auto intro!: sin_monotone_2pi_le)
        then show ?thesis by auto
      next
        case 2
        then have "- sin y ≤ - sin u"
          using that bounds
          unfolding sin_minus_pi[symmetric]
          apply (intro sin_monotone_2pi_le)
          by (auto intro!: )
        then show ?thesis by auto
      qed
    qed
    have "cos xn ∈ aform_err e Y"
      apply (rule min_range_antimono[OF xn lxn uxn min_eq_Some e, where f'="λx. - sin x"])
      subgoal by simp
      subgoal by simp
      subgoal by (auto intro!: derivative_eq_intros)
      subgoal by (rule diff_le) auto
      done
    then show ?thesis
      unfolding xn_def
      by (simp add: )
  next
    case 2
    then have min_eq_Some: "min_range_mono p Cos (λx. Minus (Sin x)) l u X = Some Y"
      and bounds: "ub_pi p ≤ l" "u ≤ 2 * lb_pi p"
      using assms(2)
      unfolding cos_aform_err_def X
      by (auto simp: X Let_def simp flip: l_def u_def ivl_def split: prod.splits)
    have bounds: "pi ≤ l" "u ≤ 2 * pi" using bounds pi_boundaries[of p] by auto
    have diff_le: "min (- sin (real_of_float l)) (- sin (real_of_float u)) ≤ - sin y"
      if "real_of_float l ≤ y" "y ≤ real_of_float u" for y
    proof -
      consider "y ≤ 3 * pi / 2" | "y ≥ 3 * pi / 2" by arith
      then show ?thesis
      proof cases
        case 1
        then have "- sin l ≤ - sin y"
          unfolding sin_minus_pi[symmetric]
          apply (intro sin_monotone_2pi_le)
          using that bounds
          by (auto)
        then show ?thesis by auto
      next
        case 2
        then have "- sin u ≤ - sin y"
          unfolding sin_2pi_minus[symmetric]
          using that bounds
          apply (intro sin_monotone_2pi_le)
          by (auto intro!: )
        then show ?thesis by auto
      qed
    qed
    have "cos xn ∈ aform_err e Y"
      apply (rule min_range_mono[OF xn lxn uxn min_eq_Some e, where f'="λx. - sin x"])
      subgoal by simp
      subgoal by simp
      subgoal by (auto intro!: derivative_eq_intros)
      subgoal by (rule diff_le) auto
      done
    then show ?thesis
      unfolding xn_def
      by (simp add: )
  next
    case 3
    then obtain ivl' where
      "cos_float_interval p ivl = ivl'"
      "Y = ivl_err (real_interval ivl')"
      using assms(2)
      unfolding cos_aform_err_def X l_def u_def
      by (auto simp: X simp flip: l_def u_def ivl_def split: prod.splits)
    with cos_float_intervalI[OF ‹xn ∈⇩_r ivl›, of p]
    show ?thesis
      by (auto simp: xn_def)
  qed
qed

definition "sqrt_aform_err p X = do {
  let ivl = ivl_of_aform_err p X;
  let l = lower ivl;
  let u = upper ivl;
  if 0 < l then min_range_mono p Sqrt (λx. Half (Inverse (Sqrt x))) l u X
  else Some (ivl_err (real_interval (sqrt_float_interval p ivl)))
}"

lemma sqrt_aform_err:
  assumes x: "x ∈ aform_err e X"
  assumes "sqrt_aform_err p X = Some Y"
  assumes e: "e ∈ UNIV → {-1 .. 1}"
  shows "sqrt x ∈ aform_err e Y"
proof -
  obtain l u ivl
    where ivl_def: "ivl = ivl_of_aform_err p X"
    and l_def: "l = lower ivl"
    and u_def: "u = upper ivl"
    by auto
  from ivl_of_aform_err[OF e x, of p, folded ivl_def]
  have ivl: "x ∈⇩_r ivl" .
  then have lx: "l ≤ x" and ux: "x ≤ u"
    by (auto simp flip: ivl_def simp: l_def u_def set_of_eq)
  consider "l > 0" | "l ≤ 0"
    by arith
  then show ?thesis
  proof cases
    case 1
    then have min_eq_Some: "min_range_mono p Sqrt (λx. Half (Inverse (Sqrt x))) l u X = Some Y"
      and bounds: "0 < l"
      using assms(2)
      unfolding sqrt_aform_err_def
      by (auto simp: Let_def simp flip: l_def u_def ivl_def split: prod.splits)
    have "sqrt x ∈ aform_err e Y"
      apply (rule min_range_mono[OF x lx ux min_eq_Some e, where f'="λx. 1 / (2 * sqrt x)"])
      subgoal by simp
      subgoal by (simp add: divide_simps)
      subgoal using bounds by (auto intro!: derivative_eq_intros simp: inverse_eq_divide)
      subgoal using ‹l > 0› by (auto simp: inverse_eq_divide min_def divide_simps)
      done
    then show ?thesis
      by (simp add: )
  next
    case 2
    then have "Y = ivl_err (real_interval (sqrt_float_interval p ivl))"
      using assms(2)
      unfolding sqrt_aform_err_def
      by (auto simp: Let_def simp flip: ivl_def l_def u_def split: prod.splits)
    with sqrt_float_intervalI[OF ivl]
    show ?thesis
      by (auto simp: set_of_eq)
  qed
qed

definition "ln_aform_err p X = do {
  let ivl = ivl_of_aform_err p X;
  let l = lower ivl;
  if 0 < l then min_range_mono p Ln inverse l (upper ivl) X
  else None
}"

lemma ln_aform_err:
  assumes x: "x ∈ aform_err e X"
  assumes "ln_aform_err p X = Some Y"
  assumes e: "e ∈ UNIV → {-1 .. 1}"
  shows "ln x ∈ aform_err e Y"
proof -
  obtain ivl l u
    where l_def: "l = lower ivl"
      and u_def: "u = upper ivl"
      and ivl_def: "ivl = ivl_of_aform_err p X"
    by auto
  from ivl_of_aform_err[OF e x, of p, folded ivl_def]
  have "x ∈⇩_r ivl" .
  then have lx: "l ≤ x" and ux: "x ≤ u"
    by (auto simp: set_of_eq l_def u_def)
  consider "l > 0" | "l ≤ 0"
    by arith
  then show ?thesis
  proof cases
    case 1
    then have min_eq_Some: "min_range_mono p Ln inverse l u X = Some Y"
      and bounds: "0 < l"
      using assms(2)
      unfolding ln_aform_err_def
      by (auto simp: Let_def simp flip: ivl_def l_def u_def split: prod.splits if_splits)
    have "ln x ∈ aform_err e Y"
      apply (rule min_range_mono[OF x lx ux min_eq_Some e, where f'=inverse])
      subgoal by simp
      subgoal by (simp add: divide_simps)
      subgoal using bounds by (auto intro!: derivative_eq_intros simp: inverse_eq_divide)
      subgoal using ‹l > 0› by (auto simp: inverse_eq_divide min_def divide_simps)
      done
    then show ?thesis
      by (simp add: )
  next
    case 2
    then show ?thesis using assms
      by (auto simp: ln_aform_err_def Let_def l_def ivl_def)
  qed
qed

definition "exp_aform_err p X = do {
  let ivl = ivl_of_aform_err p X;
  min_range_mono p Exp Exp (lower ivl) (upper ivl) X
}"

lemma exp_aform_err:
  assumes x: "x ∈ aform_err e X"
  assumes "exp_aform_err p X = Some Y"
  assumes e: "e ∈ UNIV → {-1 .. 1}"
  shows "exp x ∈ aform_err e Y"
proof -
  obtain l u ivl
    where l_def: "l = lower ivl"
      and u_def: "u = upper ivl"
      and ivl_def: "ivl = ivl_of_aform_err p X"
    by auto
  from ivl_of_aform_err[OF e x, of p, folded ivl_def]
  have "x ∈⇩_r ivl" .
  then have lx: "l ≤ x" and ux: "x ≤ u"
    by (auto simp: ivl_def l_def u_def set_of_eq)
  have min_eq_Some: "min_range_mono p Exp Exp l u X = Some Y"
    using assms(2)
    unfolding exp_aform_err_def
    by (auto simp: Let_def simp flip: ivl_def u_def l_def split: prod.splits if_splits)
  have "exp x ∈ aform_err e Y"
    apply (rule min_range_mono[OF x lx ux min_eq_Some e, where f'=exp])
    subgoal by simp
    subgoal by (simp add: divide_simps)
    subgoal by (auto intro!: derivative_eq_intros simp: inverse_eq_divide)
    subgoal by (auto simp: inverse_eq_divide min_def divide_simps)
    done
  then show ?thesis
    by (simp add: )
qed

definition "arctan_aform_err p X = do {
  let l = Inf_aform_err p X;
  let u = Sup_aform_err p X;
  min_range_mono p Arctan (λx. 1 / (Num 1 + x * x)) l u X
}"

lemma pos_add_nonneg_ne_zero: "a > 0 ⟹ b ≥ 0 ⟹ a + b ≠ 0"
  for a b::real
  by arith

lemma arctan_aform_err:
  assumes x: "x ∈ aform_err e X"
  assumes "arctan_aform_err p X = Some Y"
  assumes e: "e ∈ UNIV → {-1 .. 1}"
  shows "arctan x ∈ aform_err e Y"
proof -
  obtain l u where l: "l = Inf_aform_err p X"
    and u: "u = Sup_aform_err p X"
    by auto
  from x l u have lx: "l ≤ x" and ux: "x ≤ u"
    using Inf_Sup_aform_err[OF e, of X p]
    by auto
  have min_eq_Some: "min_range_mono p Arctan (λx. 1 / (Num 1 + x * x))  l u X = Some Y"
    using assms(2)
    unfolding arctan_aform_err_def l u
    by (auto simp: l[symmetric] u[symmetric] split: prod.splits if_splits)
  have "arctan x ∈ aform_err e Y"
    apply (rule min_range_mono[OF x lx ux min_eq_Some e, where f'="λx. inverse (1 + x⇧²)"])
    subgoal by simp
    subgoal by (simp add: power2_eq_square inverse_eq_divide)
    subgoal by (auto intro!: derivative_eq_intros simp: inverse_eq_divide)
    subgoal for x
      apply (cases "x ≤ 0")
      subgoal
        apply (rule min.coboundedI1)
        apply (rule deriv_nonneg_imp_mono[of "real_of_float l" x])
        by (auto intro!: derivative_eq_intros simp: mult_le_0_iff pos_add_nonneg_ne_zero)
      subgoal
        apply (rule min.coboundedI2)
        apply (rule le_imp_inverse_le)
        by (auto intro!: power_mono add_pos_nonneg)
      done
    done
  then show ?thesis
    by (simp add: )
qed

subsection ‹Power, TODO: compare with Min-range approximation?!›

definition "power_aform_err p (X::aform_err) n =
  (if n = 0 then ((1, zero_pdevs), 0)
  else if n = 1 then X
  else
    let x0 = float_of (fst (fst X));
      xs = snd (fst X);
      xe = float_of (snd X);
      C = the (approx p (Num x0 ^⇩_e n) []);
      (c, ce) = mid_err C;
      NX = the (approx p (Num (of_nat n) * (Num x0 ^⇩_e (n - 1))) []);
      (nx, nxe) = mid_err NX;
      Y = scaleR_pdevs nx xs;
      (Y', Y_err) = trunc_bound_pdevs p Y;
      t = tdev' p xs;
      Ye = truncate_up p (nxe * t);
      err = the (approx p
        (Num (of_nat n) * Num xe * Abs (Num x0) ^⇩_e (n - 1) + 
        (Sum⇩_e (λk. Num (of_nat (n choose k)) * Abs (Num x0) ^⇩_e (n - k) * (Num xe + Num (float_of t)) ^⇩_e k)
          [2..<Suc n])) []);
      ERR = upper err
    in ((c, Y'), sum_list' p [ce, Y_err, Ye, real_of_float ERR]))"

lemma bounded_by_Nil: "bounded_by [] []"
  by (auto simp: bounded_by_def)

lemma plain_floatarith_approx:
  assumes "plain_floatarith 0 f"
  shows "interpret_floatarith f [] ∈⇩_r (the (approx p f []))"
proof -
  from plain_floatarith_approx_not_None[OF assms(1), of Nil p]
  obtain ivl where "approx p f [] = Some ivl"
    by auto
  from this approx[OF bounded_by_Nil this]
  show ?thesis
    by auto
qed

lemma plain_floatarith_Sum⇩_e:
  "plain_floatarith n (Sum⇩_e f xs) ⟷ list_all (λi. plain_floatarith n (f i)) xs"
  by (induction xs) (auto simp: zero_floatarith_def plus_floatarith_def)

lemma sum_list'_float[simp]: "sum_list' p xs ∈ float"
  by (induction xs rule: rev_induct) (auto simp: sum_list'_def eucl_truncate_up_real_def)

lemma tdev'_float[simp]: "tdev' p xs ∈ float"
  by (auto simp: tdev'_def)

lemma
  fixes x y::real
  assumes "abs (x - y) ≤ e"
  obtains err where "x = y + err" "abs err ≤ e"
  using assms
  apply atomize_elim
  apply (rule exI[where x="x - y"])
  by (auto simp: abs_real_def)

theorem power_aform_err:
  assumes "x ∈ aform_err e X"
  assumes floats[simp]: "fst (fst X) ∈ float" "snd X ∈ float"
  assumes e: "e ∈ UNIV → {-1 .. 1}"
  shows "x ^ n ∈ aform_err e (power_aform_err p X n)"
proof -
  consider "n = 0" | "n = 1" | "n ≥ 2"
    by arith
  then show ?thesis
  proof cases
    case 1
    then show ?thesis by (auto simp: aform_err_def power_aform_err_def aform_val_def)
  next
    case 2
    then show ?thesis
      using assms
      by (auto simp: aform_err_def power_aform_err_def aform_val_def)
  next
    case n: 3
    define x0 where "x0 = (fst (fst X))"
    define xs where "xs = snd (fst X)"
    define xe where "xe = (snd X)"
    have [simp]: "x0 ∈ float" "xe ∈ float" using assms by (auto simp: x0_def xe_def)
  
    define xe' where "xe' = x - aform_val e (x0, xs)"
    from aform_errE[OF assms(1)]
    have xe': "¦xe'¦ ≤ xe"
      by (auto simp: x0_def xs_def xe_def xe'_def)
    then have xe_nonneg: "0 ≤ xe"
      by (auto simp: )

    define t where "t = tdev' p xs"
    have t: "tdev xs ≤ t" "t ∈ float" by (auto simp add: t_def tdev'_le)
    then have t_nonneg: "0 ≤ t" using tdev_nonneg[of xs] by arith
    note t_pdevs = abs_pdevs_val_le_tdev[OF e, THEN order_trans, OF t(1)]

    have rewr1: "{..n} = (insert 0 (insert 1 {2..n}))" using n by auto
    have "x = (pdevs_val e xs + xe') + x0"
      by (simp add: xe'_def aform_val_def)
    also have "… ^ n = x0 ^ n + n * x0 ^ (n - Suc 0) * pdevs_val e xs +
      (n * xe' * x0 ^ (n - Suc 0) +
        (∑k = 2..n. real (n choose k) * (pdevs_val e xs + xe') ^ k * x0 ^ (n - k)))"
      (is "_ = _ + ?err")
      apply (subst binomial_ring)
      unfolding rewr1
      using n
      apply (simp add: algebra_simps)
      done
    also

    let ?ERR = "(Num (of_nat n) * Num (float_of xe) * Abs (Num (float_of x0)) ^⇩_e (n - 1) +
          (Sum⇩_e (λk. Num (of_nat (n choose k)) * Abs (Num (float_of x0)) ^⇩_e (n - k) *
            (Num (float_of xe) + Num (float_of t)) ^⇩_e k)
            [2..<Suc n]))"
    define err where "err = the (approx p ?ERR [])"
    define ERR where "ERR = upper err"
    have ERR: "abs ?err ≤ ERR"
    proof -
      have err_aerr: "abs (?err) ≤ n * xe * abs x0 ^ (n - Suc 0) +
          (∑k = 2..n. real (n choose k) * (t + xe) ^ k * abs x0 ^ (n - k))"
        (is "_ ≤ ?aerr")
        by (auto simp: abs_mult power_abs intro!: sum_mono mult_mono power_mono xe'
            mult_nonneg_nonneg zero_le_power t_nonneg xe_nonneg add_nonneg_nonneg
            sum_abs[THEN order_trans] abs_triangle_ineq[THEN order_trans] add_mono t_pdevs)
      also
      have rewr: "{2 .. n} = {2 ..<Suc n}"
        using n
        by (auto simp: )
      have "plain_floatarith 0 ?ERR"
        by (auto simp add: zero_floatarith_def plain_floatarith_Sum⇩_e times_floatarith_def
            plus_floatarith_def intro!: list_allI)
      from plain_floatarith_approx[OF this, of p]
      have "ERR ≥ ?aerr"
        using n
        by (auto simp: set_of_eq err_def ERR_def sum_list_distinct_conv_sum_set rewr t x0_def
            algebra_simps)
      finally show ?thesis .
    qed

    let ?x0n = "Num (float_of x0) ^⇩_e n"
    define C where "C = the (approx p ?x0n [])"
    have "plain_floatarith 0 ?x0n" by simp
    from plain_floatarith_approx[OF this, of p]
    have C: "x0 ^ n ∈ {lower C .. upper C}"
      by (auto simp: C_def x0_def set_of_eq)

    define c where "c = fst (mid_err C)"
    define ce where "ce = snd (mid_err C)"
    define ce' where "ce' = x0 ^ n - c"
    have ce': "abs (ce') ≤ ce"
      using C
      by (auto simp: ce'_def c_def ce_def abs_diff_le_iff mid_err_def divide_simps)
    have "x0 ^ n = c + ce'" by (simp add: ce'_def)
    also

    let ?NX = "(Num (of_nat n) * (Num (float_of x0) ^⇩_e (n - 1)))"
    define NX where "NX = the (approx p ?NX [])"
    have "plain_floatarith 0 ?NX" by (simp add: times_floatarith_def)
    from plain_floatarith_approx[OF this, of p]
    have NX: "n * x0 ^ (n - 1) ∈ {lower NX .. upper NX}"
      by (auto simp: NX_def x0_def set_of_eq)

    define nx where "nx = fst (mid_err NX)"
    define nxe where "nxe = snd (mid_err NX)"
    define nx' where "nx' = n * x0 ^ (n - 1) - nx"
    define Ye where "Ye = truncate_up p (nxe * t)"
    have Ye: "Ye ≥ nxe * t" by (auto simp: Ye_def truncate_up_le)
    have nx: "abs (nx') ≤ nxe" "0 ≤ nxe"
      using NX
      by (auto simp: nx_def nxe_def abs_diff_le_iff mid_err_def divide_simps nx'_def)
    have Ye: "abs (nx' * pdevs_val e xs) ≤ Ye"
      by (auto simp: Ye_def abs_mult intro!: truncate_up_le mult_mono nx t_pdevs)
    have "n * x0 ^ (n - Suc 0) = nx + nx'" by (simp add: nx'_def)
    also

    define Y where "Y = scaleR_pdevs nx xs"
    have Y: "pdevs_val e Y = nx * pdevs_val e xs"
      by (simp add: Y_def)
    have "(nx + nx') * pdevs_val e xs = pdevs_val e Y + nx' * pdevs_val e xs"
      unfolding Y by (simp add: algebra_simps)
    also

    define Y' where "Y' = fst (trunc_bound_pdevs p Y)"
    define Y_err where "Y_err = snd (trunc_bound_pdevs p Y)"
    have Y_err: "abs (- pdevs_val e (trunc_err_pdevs p Y)) ≤ Y_err"
      by (auto simp: Y_err_def trunc_bound_pdevs_def abs_pdevs_val_le_tdev' e)
    have "pdevs_val e Y = pdevs_val e Y' + - pdevs_val e (trunc_err_pdevs p Y)"
      by (simp add: Y'_def trunc_bound_pdevs_def pdevs_val_trunc_err_pdevs)
    finally
    have "¦x ^ n - aform_val e (c, Y') ¦ =
      ¦ce' + - pdevs_val e (trunc_err_pdevs p Y) + nx' * pdevs_val e xs + ?err¦"
      by (simp add: algebra_simps aform_val_def)
    also have "… ≤ ce + Y_err + Ye + ERR"
      by (intro ERR abs_triangle_ineq[THEN order_trans] add_mono ce' Ye Y_err)
    also have "… ≤ sum_list' p [ce, Y_err, Ye, real_of_float ERR]"
      by (auto intro!: sum_list'_sum_list_le)
    finally show ?thesis
      using n
      by (intro aform_errI)
        (auto simp: power_aform_err_def c_def Y'_def C_def Y_def ERR_def x0_def nx_def xs_def NX_def
          ce_def Y_err_def Ye_def xe_def nxe_def t_def Let_def split_beta' set_of_eq err_def)
  qed
qed

definition [code_abbrev]: "is_float r ⟷ r ∈ float"
lemma [code]: "is_float (real_of_float f) = True"
  by (auto simp: is_float_def)

definition "powr_aform_err p X A = (
    if Inf_aform_err p X > 0 then do {
      L ← ln_aform_err p X;
      exp_aform_err p (mult_aform' p A L)
    }
    else approx_bin p (powr_float_interval p) X A)"

lemma interval_extension_powr: "interval_extension2 (powr_float_interval p) (powr)"
  using powr_float_interval_eqI[of p]
  by (auto simp: interval_extension2_def)

theorem powr_aform_err:
  assumes x: "x ∈ aform_err e X"
  assumes a: "a ∈ aform_err e A"
  assumes e: "e ∈ UNIV → {-1 .. 1}"
  assumes Y: "powr_aform_err p X A = Some Y"
  shows "x powr a ∈ aform_err e Y"
proof cases
  assume pos: "Inf_aform_err p X > 0"
  with Inf_Sup_aform_err[OF e, of X p] x
  have "x > 0" by auto
  then have "x powr a = exp (a * ln x)"
    by (simp add: powr_def)
  also
  from pos obtain L where L: "ln_aform_err p X = Some L"
    and E: "exp_aform_err p (mult_aform' p A L) = Some Y"
    using Y
    by (auto simp: bind_eq_Some_conv powr_aform_err_def)
  from ln_aform_err[OF x L e] have "ln x ∈ aform_err e L" .
  from mult_aform'E[OF e a this] have "a * ln x ∈ aform_err e (mult_aform' p A L)" .
  from exp_aform_err[OF this E e]
  have "exp (a * ln x) ∈ aform_err e Y" .
  finally show ?thesis .
next
  from x a have xa: "x ∈ aform_err e (fst X, snd X)" "a ∈ aform_err e (fst A, snd A)" by simp_all
  assume "¬ Inf_aform_err p X > 0"
  then have "approx_bin p (powr_float_interval p) (fst X, snd X) (fst A, snd A) = Some Y"
    using Y by (auto simp: powr_aform_err_def)
  from approx_binE[OF interval_extension_powr xa this e]
  show "x powr a ∈ aform_err e Y" .
qed

fun
  approx_floatarith :: "nat ⇒ floatarith ⇒ aform_err list ⇒ (aform_err) option"
where
  "approx_floatarith p (Add a b) vs =
    do {
      a1 ← approx_floatarith p a vs;
      a2 ← approx_floatarith p b vs;
      Some (add_aform' p a1 a2)
    }"
| "approx_floatarith p (Mult a b) vs =
    do {
      a1 ← approx_floatarith p a vs;
      a2 ← approx_floatarith p b vs;
      Some (mult_aform' p a1 a2)
    }"
| "approx_floatarith p (Inverse a) vs =
    do {
      a ← approx_floatarith p a vs;
      inverse_aform_err p a
    }"
| "approx_floatarith p (Minus a) vs =
    map_option (apfst uminus_aform) (approx_floatarith p a vs)"
| "approx_floatarith p (Num f) vs =
    Some (num_aform (real_of_float f), 0)"
| "approx_floatarith p (Var i) vs =
  (if i < length vs then Some (vs ! i) else None)"
| "approx_floatarith p (Abs a) vs =
    do {
      r ← approx_floatarith p a vs;
      let ivl = ivl_of_aform_err p r;
      let i = lower ivl;
      let s = upper ivl;
      if i > 0 then Some r
      else if s < 0 then Some (apfst uminus_aform r)
      else do {
        Some (ivl_err (real_interval (abs_interval ivl)))
      }
    }"
| "approx_floatarith p (Min a b) vs =
    do {
      a1 ← approx_floatarith p a vs;
      a2 ← approx_floatarith p b vs;
      Some (min_aform_err p a1 a2)
    }"
| "approx_floatarith p (Max a b) vs =
    do {
      a1 ← approx_floatarith p a vs;
      a2 ← approx_floatarith p b vs;
      Some (max_aform_err p a1 a2)
    }"
| "approx_floatarith p (Floor a) vs =
    approx_un p (λivl. Some (floor_float_interval ivl)) (approx_floatarith p a vs)"
| "approx_floatarith p (Cos a) vs =
    do {
      a ← approx_floatarith p a vs;
      cos_aform_err p a
    }"
| "approx_floatarith p Pi vs = Some (ivl_err (real_interval (pi_float_interval p)))"
| "approx_floatarith p (Sqrt a) vs =
    do {
      a ← approx_floatarith p a vs;
      sqrt_aform_err p a
    }"
| "approx_floatarith p (Ln a) vs =
    do {
      a ← approx_floatarith p a vs;
      ln_aform_err p a
    }"
| "approx_floatarith p (Arctan a) vs =
    do {
      a ← approx_floatarith p a vs;
      arctan_aform_err p a
    }"
| "approx_floatarith p (Exp a) vs =
    do {
      a ← approx_floatarith p a vs;
      exp_aform_err p a
    }"
| "approx_floatarith p (Power a n) vs =
    do {
      ((a, as), e) ← approx_floatarith p a vs;
      if is_float a ∧ is_float e then Some (power_aform_err p ((a, as), e) n)
      else None
    }"
| "approx_floatarith p (Powr a b) vs =
    do {
      ae1 ← approx_floatarith p a vs;
      ae2 ← approx_floatarith p b vs;
      powr_aform_err p ae1 ae2
    }"

lemma uminus_aform_uminus_aform[simp]: "uminus_aform (uminus_aform z) = (z::'a::real_vector aform)"
  by (auto intro!: prod_eqI pdevs_eqI simp: uminus_aform_def)

lemma degree_aform_inverse_aform':
  "degree_aform X ≤ n ⟹ degree_aform (fst (inverse_aform' p X)) ≤ n"
  unfolding inverse_aform'_def
  by (auto simp: Let_def trunc_bound_pdevs_def intro!: degree_pdev_upd_le degree_trunc_pdevs_le)

lemma degree_aform_inverse_aform:
  assumes "inverse_aform p X = Some Y"
  assumes "degree_aform X ≤ n"
  shows "degree_aform (fst Y) ≤ n"
  using assms
  by (auto simp: inverse_aform_def Let_def degree_aform_inverse_aform' split: if_splits)

lemma degree_aform_ivl_err[simp]: "degree_aform (fst (ivl_err a)) = 0"
  by (auto simp: ivl_err_def)

lemma degree_aform_approx_bin:
  assumes "approx_bin p ivl X Y = Some Z"
  assumes "degree_aform (fst X) ≤ m"
  assumes "degree_aform (fst Y) ≤ m"
  shows "degree_aform (fst Z) ≤ m"
  using assms
  by (auto simp: approx_bin_def bind_eq_Some_conv Basis_list_real_def
      intro!: order_trans[OF degree_aform_independent_from]
      order_trans[OF degree_aform_of_ivl])

lemma degree_aform_approx_un:
  assumes "approx_un p ivl X = Some Y"
  assumes "case X of None ⇒ True | Some X ⇒ degree_aform (fst X) ≤ d1"
  shows "degree_aform (fst Y) ≤ d1"
  using assms
  by (auto simp: approx_un_def bind_eq_Some_conv Basis_list_real_def
      intro!: order_trans[OF degree_aform_independent_from]
      order_trans[OF degree_aform_of_ivl])

lemma degree_aform_num_aform[simp]: "degree_aform (num_aform x) = 0"
  by (auto simp: num_aform_def)

lemma degree_max_aform:
  assumes "degree_aform_err x ≤ d"
  assumes "degree_aform_err y ≤ d"
  shows "degree_aform_err (max_aform_err p x y) ≤ d"
  using assms
  by (auto simp: max_aform_err_def Let_def Basis_list_real_def split: prod.splits
      intro!: order_trans[OF degree_aform_independent_from] order_trans[OF degree_aform_of_ivl])

lemma degree_min_aform:
  assumes "degree_aform_err x ≤ d"
  assumes "degree_aform_err y ≤ d"
  shows "degree_aform_err ((min_aform_err p x y)) ≤ d"
  using assms
  by (auto simp: min_aform_err_def Let_def Basis_list_real_def split: prod.splits
      intro!: order_trans[OF degree_aform_independent_from] order_trans[OF degree_aform_of_ivl])

lemma degree_aform_acc_err:
  "degree_aform (fst (acc_err p X e)) ≤ d"
  if "degree_aform (fst X) ≤ d"
  using that by (auto simp: acc_err_def)

lemma degree_pdev_upd_degree:
  assumes "degree b ≤ Suc n"
  assumes "degree b ≤ Suc (degree_aform_err X)"
  assumes "degree_aform_err X ≤ n"
  shows "degree (pdev_upd b (degree_aform_err X) 0) ≤ n"
  using assms
  by (auto intro!: degree_le)

lemma degree_aform_err_inverse_aform_err:
  assumes "inverse_aform_err p X = Some Y"
  assumes "degree_aform_err X ≤ n"
  shows "degree_aform_err Y ≤ n"
  using assms
  apply (auto simp: inverse_aform_err_def bind_eq_Some_conv aform_to_aform_err_def
      acc_err_def map_aform_err_def
      aform_err_to_aform_def
      intro!: degree_aform_acc_err)
  apply (rule degree_pdev_upd_degree)
    apply (auto dest!: degree_aform_inverse_aform)
  apply (meson degree_pdev_upd_le nat_le_linear not_less_eq_eq order_trans)
  apply (meson degree_pdev_upd_le nat_le_linear not_less_eq_eq order_trans)
  done

lemma degree_aform_err_affine_unop:
  "degree_aform_err (affine_unop p a b d X) ≤ n"
  if "degree_aform_err X ≤ n"
  using that
  by (auto simp: affine_unop_def trunc_bound_pdevs_def degree_trunc_pdevs_le split: prod.splits)


lemma degree_aform_err_min_range_mono:
  assumes "min_range_mono p F D l u X = Some Y"
  assumes "degree_aform_err X ≤ n"
  shows "degree_aform_err Y ≤ n"
  using assms
  by (auto simp: min_range_mono_def bind_eq_Some_conv aform_to_aform_err_def
      acc_err_def map_aform_err_def mid_err_def range_reduce_aform_err_def
      aform_err_to_aform_def Let_def split: if_splits prod.splits
      intro!: degree_aform_err_affine_unop)

lemma degree_aform_err_min_range_antimono:
  assumes "min_range_antimono p F D l u X = Some Y"
  assumes "degree_aform_err X ≤ n"
  shows "degree_aform_err Y ≤ n"
  using assms
  by (auto simp: min_range_antimono_def bind_eq_Some_conv aform_to_aform_err_def
      acc_err_def map_aform_err_def mid_err_def range_reduce_aform_err_def
      aform_err_to_aform_def Let_def split: if_splits prod.splits
      intro!: degree_aform_err_affine_unop)

lemma degree_aform_err_cos_aform_err:
  assumes "cos_aform_err p X = Some Y"
  assumes "degree_aform_err X ≤ n"
  shows "degree_aform_err Y ≤ n"
  using assms
  apply (auto simp: cos_aform_err_def bind_eq_Some_conv aform_to_aform_err_def
      acc_err_def map_aform_err_def mid_err_def range_reduce_aform_err_def
      aform_err_to_aform_def Let_def split: if_splits prod.splits
      intro!: degree_aform_err_affine_unop)
  apply (metis degree_aform_err_add_aform' degree_aform_err_min_range_antimono degree_aform_ivl_err zero_le)
  apply (metis degree_aform_err_add_aform' degree_aform_err_min_range_mono degree_aform_ivl_err zero_le)
  apply (metis degree_aform_err_add_aform' degree_aform_err_min_range_mono degree_aform_ivl_err zero_le)
  apply (metis degree_aform_err_add_aform' degree_aform_err_min_range_antimono degree_aform_ivl_err zero_le)
  apply (metis degree_aform_err_add_aform' degree_aform_err_min_range_antimono degree_aform_ivl_err zero_le)
  apply (metis degree_aform_err_add_aform' degree_aform_err_min_range_antimono degree_aform_ivl_err zero_le)
  done

lemma degree_aform_err_sqrt_aform_err:
  assumes "sqrt_aform_err p X = Some Y"
  assumes "degree_aform_err X ≤ n"
  shows "degree_aform_err Y ≤ n"
  using assms
  apply (auto simp: sqrt_aform_err_def Let_def split: if_splits)
  apply (metis degree_aform_err_min_range_mono)
  done

lemma degree_aform_err_arctan_aform_err:
  assumes "arctan_aform_err p X = Some Y"
  assumes "degree_aform_err X ≤ n"
  shows "degree_aform_err Y ≤ n"
  using assms
  apply (auto simp: arctan_aform_err_def bind_eq_Some_conv)
  apply (metis degree_aform_err_min_range_mono)
  done

lemma degree_aform_err_exp_aform_err:
  assumes "exp_aform_err p X = Some Y"
  assumes "degree_aform_err X ≤ n"
  shows "degree_aform_err Y ≤ n"
  using assms
  apply (auto simp: exp_aform_err_def bind_eq_Some_conv)
  apply (metis degree_aform_err_min_range_mono)
  done

lemma degree_aform_err_ln_aform_err:
  assumes "ln_aform_err p X = Some Y"
  assumes "degree_aform_err X ≤ n"
  shows "degree_aform_err Y ≤ n"
  using assms
  apply (auto simp: ln_aform_err_def Let_def split: if_splits)
  apply (metis degree_aform_err_add_aform' degree_aform_err_min_range_mono degree_aform_ivl_err zero_le)
  done

lemma degree_aform_err_power_aform_err:
  assumes "degree_aform_err X ≤ n"
  shows "degree_aform_err (power_aform_err p X m) ≤ n"
  using assms
  by (auto simp: power_aform_err_def Let_def trunc_bound_pdevs_def degree_trunc_pdevs_le
      split: if_splits prod.splits)

lemma degree_aform_err_powr_aform_err:
  assumes "powr_aform_err p X Z = Some Y"
  assumes "degree_aform_err X ≤ n"
  assumes "degree_aform_err Z ≤ n"
  shows "degree_aform_err Y ≤ n"
  using assms
  apply (auto simp: powr_aform_err_def bind_eq_Some_conv degree_aform_mult_aform'
      dest!: degree_aform_err_ln_aform_err degree_aform_err_exp_aform_err
      split: if_splits)
  apply (metis degree_aform_mult_aform' fst_conv order_trans snd_conv)
  apply (rule degree_aform_approx_bin, assumption)
  apply auto
  done

lemma approx_floatarith_degree:
  assumes "approx_floatarith p ra VS = Some X"
  assumes "⋀V. V ∈ set VS ⟹ degree_aform_err V ≤ d"
  shows "degree_aform_err X ≤ d"
  using assms
proof (induction ra arbitrary: X)
  case (Add ra1 ra2)
  then show ?case 
    by (auto simp: bind_eq_Some_conv intro!: degree_aform_err_add_aform' degree_aform_acc_err)
next
  case (Minus ra)
  then show ?case
    by (auto simp: bind_eq_Some_conv)
next
  case (Mult ra1 ra2)
  then show ?case
    by (auto simp: bind_eq_Some_conv intro!: degree_aform_mult_aform' degree_aform_acc_err)
next
  case (Inverse ra)
  then show ?case
    by (auto simp: bind_eq_Some_conv intro: degree_aform_err_inverse_aform_err)
next
  case (Cos ra)
  then show ?case
    by (auto simp: bind_eq_Some_conv intro: degree_aform_err_cos_aform_err)
next
  case (Arctan ra)
  then show ?case
    by (auto simp: bind_eq_Some_conv intro: degree_aform_err_arctan_aform_err)
next
  case (Abs ra)
  then show ?case
    by (auto simp: bind_eq_Some_conv Let_def Basis_list_real_def
        intro!: order_trans[OF degree_aform_independent_from] order_trans[OF degree_aform_of_ivl]
          degree_aform_acc_err
        split: if_splits) 
next
  case (Max ra1 ra2)
  then show ?case
    by (auto simp: bind_eq_Some_conv intro!: degree_max_aform degree_aform_acc_err)
next
  case (Min ra1 ra2)
  then show ?case
    by (auto simp: bind_eq_Some_conv intro!: degree_min_aform degree_aform_acc_err)
next
  case Pi
  then show ?case
    by (auto simp: bind_eq_Some_conv Let_def Basis_list_real_def
        intro!: order_trans[OF degree_aform_independent_from] order_trans[OF degree_aform_of_ivl]
          degree_aform_acc_err
        split: if_splits)
next
  case (Sqrt ra)
  then show ?case
    by (auto simp: bind_eq_Some_conv intro: degree_aform_err_sqrt_aform_err)
next
  case (Exp ra)
  then show ?case
    by (auto simp: bind_eq_Some_conv intro: degree_aform_err_exp_aform_err)
next
  case (Powr ra1 ra2)
  then show ?case
    by (auto simp: bind_eq_Some_conv intro: degree_aform_err_powr_aform_err)
next
  case (Ln ra)
  then show ?case
    by (auto simp: bind_eq_Some_conv intro: degree_aform_err_ln_aform_err)
next
  case (Power ra x2a)
  then show ?case
    by (auto intro!: degree_aform_err_power_aform_err simp: bind_eq_Some_conv split: if_splits)
next
  case (Floor ra)
  then show ?case
    apply -
    by (rule degree_aform_approx_un) (auto split: option.splits)
next
  case (Var x)
  then show ?case
    by (auto simp: max_def split: if_splits)
      (use Var.prems(2) nat_le_linear nth_mem order_trans in blast)+
next
  case (Num x)
  then show ?case by auto
qed

definition affine_extension2 where
  "affine_extension2 fnctn_aff fnctn ⟷ (
    ∀d a1 a2 X e2.
      fnctn_aff d a1 a2 = Some X ⟶
      e2 ∈ UNIV → {- 1..1} ⟶
      d ≥ degree_aform a1 ⟶
      d ≥ degree_aform a2 ⟶
      (∃e3 ∈ UNIV → {- 1..1}.
        (fnctn (aform_val e2 a1) (aform_val e2 a2) = aform_val e3 X ∧
          (∀n. n < d ⟶ e3 n = e2 n) ∧
          aform_val e2 a1 = aform_val e3 a1 ∧ aform_val e2 a2 = aform_val e3 a2)))"

lemma affine_extension2E:
  assumes "affine_extension2 fnctn_aff fnctn"
  assumes "fnctn_aff d a1 a2 = Some X"
    "e ∈ UNIV → {- 1..1}"
    "d ≥ degree_aform a1"
    "d ≥ degree_aform a2"
  obtains e' where "e' ∈ UNIV → {- 1..1}"
    "fnctn (aform_val e a1) (aform_val e a2) = aform_val e' X"
    "⋀n. n < d ⟹ e' n = e n"
    "aform_val e a1 = aform_val e' a1"
    "aform_val e a2 = aform_val e' a2"
  using assms
  unfolding affine_extension2_def
  by metis

lemma aform_err_uminus_aform:
  "- x ∈ aform_err e (uminus_aform X, ba)"
  if "e ∈ UNIV → {-1 .. 1}" "x ∈ aform_err e (X, ba)"
  using that by (auto simp: aform_err_def)

definition "aforms_err e (xs::aform_err list) = listset (map (aform_err e) xs)"

lemma aforms_err_Nil[simp]: "aforms_err e [] = {[]}"
  and aforms_err_Cons: "aforms_err e (x#xs) = set_Cons (aform_err e x) (aforms_err e xs)"
  by (auto simp: aforms_err_def)

lemma in_set_ConsI: "a#b ∈ set_Cons A B"
  if "a ∈ A" and "b ∈ B"
  using that
  by (auto simp: set_Cons_def)

lemma mem_aforms_err_Cons_iff[simp]: "x#xs ∈ aforms_err e (X#XS) ⟷ x ∈ aform_err e X ∧ xs ∈ aforms_err e XS"
  by (auto simp: aforms_err_Cons set_Cons_def)

lemma mem_aforms_err_Cons_iff_Ex_conv: "x ∈ aforms_err e (X#XS) ⟷ (∃y ys. x = y#ys ∧ y ∈ aform_err e X ∧ ys ∈ aforms_err e XS)"
  by (auto simp: aforms_err_Cons set_Cons_def)

lemma listset_Cons_mem_conv:
  "a # vs ∈ listset AVS ⟷ (∃A VS. AVS = A # VS ∧ a ∈ A ∧ vs ∈ listset VS)"
  by (induction AVS) (auto simp: set_Cons_def)

lemma listset_Nil_mem_conv[simp]:
  "[] ∈ listset AVS ⟷ AVS = []"
  by (induction AVS) (auto simp: set_Cons_def)

lemma listset_nthD: "vs ∈ listset VS ⟹ i < length vs ⟹ vs ! i ∈ VS ! i"
  by (induction vs arbitrary: VS i)
     (auto simp: nth_Cons listset_Cons_mem_conv split: nat.splits)

lemma length_listsetD:
  "vs ∈ listset VS ⟹ length vs = length VS"
  by (induction vs arbitrary: VS) (auto simp: listset_Cons_mem_conv)

lemma length_aforms_errD:
  "vs ∈ aforms_err e VS ⟹ length vs = length VS"
  by (auto simp: aforms_err_def length_listsetD)

lemma nth_aforms_errI:
  "vs ! i ∈ aform_err e (VS ! i)"
  if "vs ∈ aforms_err e VS" "i < length vs"
  using that
  unfolding aforms_err_def
  apply -
  apply (frule listset_nthD, assumption)
  by (auto simp: aforms_err_def length_listsetD )

lemma eucl_truncate_down_float[simp]: "eucl_truncate_down p x ∈ float"
  by (auto simp: eucl_truncate_down_def)

lemma eucl_truncate_up_float[simp]: "eucl_truncate_up p x ∈ float"
  by (auto simp: eucl_truncate_up_def)

lemma trunc_bound_eucl_float[simp]: "fst (trunc_bound_eucl p x) ∈ float"
  "snd (trunc_bound_eucl p x) ∈ float"
  by (auto simp: trunc_bound_eucl_def Let_def)

lemma add_aform'_float:
  "add_aform' p x y = ((a, b), ba) ⟹ a ∈ float"
  "add_aform' p x y = ((a, b), ba) ⟹ ba ∈ float"
  by (auto simp: add_aform'_def Let_def)

lemma uminus_aform_float: "uminus_aform (aa, bb) = (a, b) ⟹ aa ∈ float ⟹ a ∈ float"
  by (auto simp: uminus_aform_def)

lemma mult_aform'_float: "mult_aform' p x y = ((a, b), ba) ⟹ a ∈ float"
   "mult_aform' p x y = ((a, b), ba) ⟹ ba ∈ float"
  by (auto simp: mult_aform'_def Let_def split_beta')

lemma inverse_aform'_float: "inverse_aform' p x = ((a, bb), baa) ⟹ a ∈ float"
  using [[linarith_split_limit=256]]
  by (auto simp: inverse_aform'_def Let_def)

lemma inverse_aform_float:
  "inverse_aform p x = Some ((a, bb), baa) ⟹ a ∈ float"
  by (auto simp: inverse_aform_def Let_def apfst_def map_prod_def uminus_aform_def
      inverse_aform'_float
      split: if_splits prod.splits)

lemma inverse_aform_err_float: "inverse_aform_err p x = Some ((a, b), ba) ⟹ a ∈ float"
   "inverse_aform_err p x = Some ((a, b), ba) ⟹ ba ∈ float"
  by (auto simp: inverse_aform_err_def map_aform_err_def acc_err_def bind_eq_Some_conv
      aform_err_to_aform_def aform_to_aform_err_def inverse_aform_float)

lemma affine_unop_float:
  "affine_unop p asdf aaa bba h = ((a, b), ba) ⟹ a ∈ float"
  "affine_unop p asdf aaa bba h = ((a, b), ba) ⟹ ba ∈ float"
  by (auto simp: affine_unop_def trunc_bound_eucl_def Let_def split: prod.splits)

lemma min_range_antimono_float:
  "min_range_antimono p f f' i g h = Some ((a, b), ba) ⟹ a ∈ float"
  "min_range_antimono p f f' i g h = Some ((a, b), ba) ⟹ ba ∈ float"
  by (auto simp: min_range_antimono_def Let_def bind_eq_Some_conv mid_err_def
      affine_unop_float split: prod.splits)

lemma min_range_mono_float:
  "min_range_mono p f f' i g h = Some ((a, b), ba) ⟹ a ∈ float"
  "min_range_mono p f f' i g h = Some ((a, b), ba) ⟹ ba ∈ float"
  by (auto simp: min_range_mono_def Let_def bind_eq_Some_conv mid_err_def
      affine_unop_float split: prod.splits)

lemma in_float_timesI: "a ∈ float" if "b = a * 2" "b ∈ float"
proof -
  from that have "a = b / 2" by simp
  also have "… ∈ float" using that(2) by auto
  finally show ?thesis .
qed

lemma interval_extension_floor: "interval_extension1 (λivl. Some (floor_float_interval ivl)) floor"
  by (auto simp: interval_extension1_def floor_float_intervalI)

lemma approx_floatarith_Elem:
  assumes "approx_floatarith p ra VS = Some X"
  assumes e: "e ∈ UNIV → {-1 .. 1}"
  assumes "vs ∈ aforms_err e VS"
  shows "interpret_floatarith ra vs ∈ aform_err e X"
  using assms(1)
proof (induction ra arbitrary: X)
  case (Add ra1 ra2)
  then show ?case
    by (auto simp: bind_eq_Some_conv intro!: add_aform'[OF e])
next
  case (Minus ra)
  then show ?case
    by (auto intro!: aform_err_uminus_aform[OF e])
next
  case (Mult ra1 ra2)
  then show ?case
    by (auto simp: bind_eq_Some_conv intro!: mult_aform'E[OF e])
next
  case (Inverse ra)
  then show ?case
    by (auto simp: bind_eq_Some_conv intro!: inverse_aform_err[OF e])
next
  case (Cos ra)
  then show ?case
    by (auto simp: bind_eq_Some_conv intro!: cos_aform_err[OF _ _ e])
next
  case (Arctan ra)
  then show ?case
    by (auto simp: bind_eq_Some_conv intro!: arctan_aform_err[OF _ _ e])
next
  case (Abs fa)
  from Abs.prems
  obtain a where a: "approx_floatarith p fa VS = Some a"
    by (auto simp add: Let_def bind_eq_Some_conv)
  from Abs.IH[OF a]
  have mem: "interpret_floatarith fa vs ∈ aform_err e a"
    by auto
  then have mem': "-interpret_floatarith fa vs ∈ aform_err e (apfst uminus_aform a)"
    by (auto simp: aform_err_def)

  let ?i = "lower (ivl_of_aform_err p a)"
  let ?s = "upper (ivl_of_aform_err p a)"
  consider "?i > 0" | "?i ≤ 0" "?s < 0" | "?i ≤ 0" "?s ≥ 0"
    by arith
  then show ?case
  proof cases
    case hyps: 1
    then show ?thesis
      using Abs.prems mem ivl_of_aform_err[OF e mem, of p]
      by (auto simp: a set_of_eq)
  next
    case hyps: 2
    then show ?thesis
      using Abs.prems mem ivl_of_aform_err[OF e mem, of p]
          ivl_of_aform_err[OF e mem', of p]
      by (cases a) (auto simp: a abs_real_def set_of_eq intro!: aform_err_uminus_aform[OF e])
  next
    case hyps: 3
    then show ?thesis
      using Abs.prems mem ivl_of_aform_err[OF e mem, of p]
      by (auto simp: a abs_real_def max_def Let_def set_of_eq)
  qed
next
  case (Max ra1 ra2)
  from Max.prems
  obtain a b where a: "approx_floatarith p ra1 VS = Some a"
    and b: "approx_floatarith p ra2 VS = Some b"
    by (auto simp add: Let_def bind_eq_Some_conv)
  from Max.IH(1)[OF a] Max.IH(2)[OF b]
  have mem: "interpret_floatarith ra1 vs ∈ aform_err e a"
    "interpret_floatarith ra2 vs ∈ aform_err e b"
    by auto
  let ?ia = "lower (ivl_of_aform_err p a)"
  let ?sa = "upper (ivl_of_aform_err p a)"
  let ?ib = "lower (ivl_of_aform_err p b)"
  let ?sb = "upper (ivl_of_aform_err p b)"
  consider "?sa < ?ib" | "?sa ≥ ?ib" "?sb < ?ia" | "?sa ≥ ?ib" "?sb ≥ ?ia"
    by arith
  then show ?case
    using Max.prems mem ivl_of_aform_err[OF e mem(1), of p] ivl_of_aform_err[OF e mem(2), of p]
    by cases (auto simp: a b max_def max_aform_err_def set_of_eq)
next
  case (Min ra1 ra2)
  from Min.prems
  obtain a b where a: "approx_floatarith p ra1 VS = Some a"
    and b: "approx_floatarith p ra2 VS = Some b"
    by (auto simp add: Let_def bind_eq_Some_conv)
  from Min.IH(1)[OF a] Min.IH(2)[OF b]
  have mem: "interpret_floatarith ra1 vs ∈ aform_err e a"
    "interpret_floatarith ra2 vs ∈ aform_err e b"
    by auto
  let ?ia = "lower (ivl_of_aform_err p a)"
  let ?sa = "upper (ivl_of_aform_err p a)"
  let ?ib = "lower (ivl_of_aform_err p b)"
  let ?sb = "upper (ivl_of_aform_err p b)"
  consider "?sa < ?ib" | "?sa ≥ ?ib" "?sb < ?ia" | "?sa ≥ ?ib" "?sb ≥ ?ia"
    by arith
  then show ?case
    using Min.prems mem ivl_of_aform_err[OF e mem(1), of p] ivl_of_aform_err[OF e mem(2), of p]
    by cases (auto simp: a b min_def min_aform_err_def set_of_eq)
next
  case Pi
  then show ?case using pi_float_interval
    by (auto simp: )
next
  case (Sqrt ra)
  then show ?case
    by (auto simp: bind_eq_Some_conv intro!: sqrt_aform_err[OF _ _ e])
next
  case (Exp ra)
  then show ?case
    by (auto simp: bind_eq_Some_conv intro!: exp_aform_err[OF _ _ e])
next
  case (Powr ra1 ra2)
  then show ?case
    by (auto simp: bind_eq_Some_conv intro!: powr_aform_err[OF _ _ e])
next
  case (Ln ra)
  then show ?case
    by (auto simp: bind_eq_Some_conv intro!: ln_aform_err[OF _ _ e])
next
  case (Power ra x2a)
  then show ?case
    by (auto simp: bind_eq_Some_conv is_float_def
        intro!: power_aform_err[OF _ _ _ e] split: if_splits)
next
  case (Floor ra)
  then show ?case
    by (auto simp: bind_eq_Some_conv intro!: approx_unE[OF interval_extension_floor e]
        split: option.splits)
next
  case (Var x)
  then show ?case
    using assms(3)
    apply -
    apply (frule length_aforms_errD)
    by (auto split: if_splits simp: aform_err_def dest!: nth_aforms_errI[where i=x])
next
  case (Num x)
  then show ?case
    by (auto split: if_splits simp: aform_err_def num_aform_def aform_val_def)
qed

primrec approx_floatariths_aformerr ::
  "nat ⇒ floatarith list ⇒ aform_err list ⇒ aform_err list option"
  where
    "approx_floatariths_aformerr _ [] _ = Some []"
  | "approx_floatariths_aformerr p (a#bs) vs =
      do {
        a ← approx_floatarith p a vs;
        r ← approx_floatariths_aformerr p bs vs;
        Some (a#r)
      }"


lemma approx_floatariths_Elem:
  assumes "e ∈ UNIV → {-1 .. 1}"
  assumes "approx_floatariths_aformerr p ra VS = Some X"
  assumes "vs ∈ aforms_err e VS"
  shows "interpret_floatariths ra vs ∈ aforms_err e X"
  using assms(2)
proof (induction ra arbitrary: X)
  case Nil then show ?case by simp
next
  case (Cons ra ras)
  from Cons.prems
  obtain a r where a: "approx_floatarith p ra VS = Some a"
    and r: "approx_floatariths_aformerr p ras VS = Some r"
    and X: "X = a # r"
    by (auto simp: bind_eq_Some_conv)
  then show ?case
    using assms(1)
    by (auto simp: X Cons.IH intro!: approx_floatarith_Elem assms)
qed

lemma fold_max_mono:
  fixes x::"'a::linorder"
  shows "x ≤ y ⟹ fold max zs x ≤ fold max zs y"
  by (induct zs arbitrary: x y) (auto intro!: Cons simp: max_def)

lemma fold_max_le_self:
  fixes y::"'a::linorder"
  shows "y ≤ fold max ys y"
  by (induct ys) (auto intro: order_trans[OF _ fold_max_mono])

lemma fold_max_le:
  fixes x::"'a::linorder"
  shows "x ∈ set xs ⟹ x ≤ fold max xs z"
  by (induct xs arbitrary: x z) (auto intro: order_trans[OF _ fold_max_le_self])

abbreviation "degree_aforms_err ≡ degrees o map (snd o fst)"

definition "aforms_err_to_aforms d xs =
  (map (λ(d, x). aform_err_to_aform x d) (zip [d..<d + length xs] xs))"

lemma aform_vals_empty[simp]: "aform_vals e' [] = []"
  by (auto simp: aform_vals_def)
lemma aforms_err_to_aforms_Nil[simp]: "(aforms_err_to_aforms n []) = []"
  by (auto simp: aforms_err_to_aforms_def)

lemma aforms_err_to_aforms_Cons[simp]:
  "aforms_err_to_aforms n (X # XS) = aform_err_to_aform X n # aforms_err_to_aforms (Suc n) XS"
  by (auto simp: aforms_err_to_aforms_def not_le nth_append nth_Cons 
      intro!: nth_equalityI split: nat.splits)

lemma degree_aform_err_to_aform_le:
  "degree_aform (aform_err_to_aform X n) ≤ max (degree_aform_err X) (Suc n)"
  by (auto simp: aform_err_to_aform_def intro!: degree_le)

lemma less_degree_aform_aform_err_to_aformD: "i < degree_aform (aform_err_to_aform X n) ⟹ i < max (Suc n) (degree_aform_err X)"
  using degree_aform_err_to_aform_le[of X n] by auto

lemma pdevs_domain_aform_err_to_aform:
  "pdevs_domain (snd (aform_err_to_aform X n)) = pdevs_domain (snd (fst X)) ∪ (if snd X = 0 then {} else {n})"
  if "n ≥ degree_aform_err X"
  using that
  by (auto simp: aform_err_to_aform_def split: if_splits)

lemma length_aforms_err_to_aforms[simp]: "length (aforms_err_to_aforms i XS) = length XS"
  by (auto simp: aforms_err_to_aforms_def)

lemma aforms_err_to_aforms_ex:
  assumes X: "x ∈ aforms_err e X"
  assumes deg: "degree_aforms_err X ≤ n"
  assumes e: "e ∈ UNIV → {-1 .. 1}"
  shows "∃e'∈ UNIV → {-1 .. 1}. x = aform_vals e' (aforms_err_to_aforms n X) ∧
    (∀i < n. e' i = e i)"
  using X deg
proof (induction X arbitrary: x n)
  case Nil then show ?case using e
    by (auto simp: o_def degrees_def intro!: bexI[where x="λi. e i"])
next
  case (Cons X XS)
  from Cons.prems obtain y ys where ys:
    "degree_aform_err X ≤ n"
    "degree_aforms_err XS ≤ n"
    "x = y # ys" "y ∈ aform_err e X" "ys ∈ aforms_err e XS"
    by (auto simp: mem_aforms_err_Cons_iff_Ex_conv degrees_def)
  then have "degree_aforms_err XS ≤ Suc n" by auto
  from Cons.IH[OF ys(5) this]
  obtain e' where e': "e'∈UNIV → {- 1..1}" "ys = aform_vals e' (aforms_err_to_aforms (Suc n) XS)"
    "(∀i<n. e' i = e i)"
    by auto
  from aform_err_to_aformE[OF ys(4,1)] obtain err where err:
    "y = aform_val (e(n := err)) (aform_err_to_aform X n)" "- 1 ≤ err" "err ≤ 1"
    by auto
  show ?case
  proof (safe intro!: bexI[where x="e'(n:=err)"], goal_cases)
    case 1
    then show ?case
      unfolding ys e' err
      apply (auto simp: aform_vals_def  aform_val_def simp del:  pdevs_val_upd)
       apply (rule pdevs_val_degree_cong)
        apply simp
      subgoal
        using ys e'
        by (auto dest!: less_degree_aform_aform_err_to_aformD simp: max_def split: if_splits)
      subgoal premises prems for a b
      proof -
        have "pdevs_val (λa. if a = n then err else e' a) b = pdevs_val (e'(n:=err)) b"
          unfolding fun_upd_def by simp
        also have "… = pdevs_val e' b - e' n * pdevs_apply b n + err * pdevs_apply b n"
          by simp
        also
        from prems
        obtain i where i: "aforms_err_to_aforms (Suc n) XS ! i = (a, b)"
          "i < length (aforms_err_to_aforms (Suc n) XS)"
          by (auto simp: in_set_conv_nth )
        { note i(1)[symmetric]
          also have "aforms_err_to_aforms (Suc n) XS ! i = aform_err_to_aform (XS ! i) (Suc n + i) "
            unfolding aforms_err_to_aforms_def
            using i
            by (simp del: upt_Suc)
          finally have "b = snd (aform_err_to_aform (XS ! i) (Suc n + i))" by (auto simp: prod_eq_iff)
        } note b = this
        have "degree_aform_err (XS ! i) ≤ n"
          using ys(2) i by (auto simp:  degrees_def)
        then have "n ∉ pdevs_domain b" unfolding b
          apply (subst pdevs_domain_aform_err_to_aform)
          by (auto intro!: degree)
        then have "pdevs_apply b n = 0" by simp
        finally
        show ?thesis by simp
      qed
      done
  next
    case (2 i)
    then show ?case
      using e' by auto
  next
    case (3 i)
    then show ?case
      using e' err
      by auto
  qed
qed

lemma aforms_err_to_aformsE:
  assumes X: "x ∈ aforms_err e X"
  assumes deg: "degree_aforms_err X ≤ n"
    assumes e: "e ∈ UNIV → {-1 .. 1}"
  obtains e' where "x = aform_vals e' (aforms_err_to_aforms n X)" "e' ∈ UNIV → {-1 .. 1}"
    "⋀i. i < n ⟹ e' i = e i"
  using aforms_err_to_aforms_ex[OF X deg e]
  by blast

definition "approx_floatariths p ea as =
  do {
    let da = (degree_aforms as);
    let aes = (map (λx. (x, 0)) as);
    rs ← approx_floatariths_aformerr p ea aes;
    let d = max da (degree_aforms_err (rs));
    Some (aforms_err_to_aforms d rs)
  }"

lemma listset_sings[simp]:
  "listset (map (λx. {f x}) as) = {map f as}"
  by (induction as) (auto simp: set_Cons_def)

lemma approx_floatariths_outer:
  assumes "approx_floatariths p ea as = Some XS"
  assumes "vs ∈ Joints as"
  shows "(interpret_floatariths ea vs @ vs) ∈ Joints (XS @ as)"
proof -
  from assms obtain da aes rs d where
     da: "da = degree_aforms as"
    and aes: "aes = (map (λx. (x, 0)) as)"
    and rs: "approx_floatariths_aformerr p ea aes = Some rs"
    and d: "d = max da (degree_aforms_err (rs))"
    and XS: "aforms_err_to_aforms d rs = XS"
    by (auto simp: approx_floatariths_def Let_def bind_eq_Some_conv)
  have abbd: "(a, b) ∈ set as ⟹ degree b ≤ degree_aforms as" for a b
    apply (rule degrees_leD[OF order_refl]) by force
  from da d have i_less: "(a, b) ∈ set as ⟹ i < degree b ⟹ i < min d da" for i a b
    by (auto dest!: abbd)

  have abbd: "(a, b) ∈ set as ⟹ degree b ≤ degree_aforms as" for a b
    apply (rule degrees_leD[OF order_refl]) by force
  from assms obtain e' where vs: "vs = (map (aform_val e') as)" and e': "e' ∈ UNIV → {-1 .. 1}"
    by (auto simp: Joints_def valuate_def)
  note vs
  also
  have vs_aes: "vs ∈ aforms_err e' aes"
    unfolding aes
    by (auto simp: vs aforms_err_def o_def aform_err_def)
  from approx_floatariths_Elem[OF e' rs this]
  have iars: "interpret_floatariths ea (map (aform_val e') as) ∈ aforms_err e' rs"
    by (auto simp: vs)
  have "degree_aforms_err rs ≤ d"
    by (auto simp: d da)
  from aforms_err_to_aformsE[OF iars this e'] obtain e where
    "interpret_floatariths ea (map (aform_val e') as) = aform_vals e XS"
    and e: "e ∈ UNIV → {- 1..1}" "⋀i. i < d ⟹ e i = e' i"
    by (auto simp: XS)
  note this (1)
  finally have "interpret_floatariths ea vs = aform_vals e XS" .

  moreover

  from e have e'_eq: "e' i = e i" if "i < min d da" for i
    using that
    by (auto simp: min_def split: if_splits)
  then have "vs = aform_vals e as"
    by (auto simp: vs aform_vals_def aform_val_def intro!: pdevs_val_degree_cong e'_eq i_less)

  ultimately show ?thesis
    using e(1)
    by (auto simp: Joints_def valuate_def aform_vals_def intro!: image_eqI[where x=e])
qed

lemma length_eq_NilI: "length [] = length []"
  and length_eq_ConsI: "length xs = length ys ⟹ length (x#xs) = length (y#ys)"
  by auto


subsection ‹Generic operations on Affine Forms in Euclidean Space›

lemma pdevs_val_domain_cong:
  assumes "b = d"
  assumes "⋀i. i ∈ pdevs_domain b ⟹ a i = c i"
  shows "pdevs_val a b = pdevs_val c d"
  using assms
  by (auto simp: pdevs_val_pdevs_domain)

lemma fresh_JointsI:
  assumes "xs ∈ Joints XS"
  assumes "list_all (λY. pdevs_domain (snd X) ∩ pdevs_domain (snd Y) = {}) XS"
  assumes "x ∈ Affine X"
  shows "x#xs ∈ Joints (X#XS)"
  using assms
  unfolding Joints_def Affine_def valuate_def
proof safe
  fix e e'::"nat ⇒ real"
  assume H: "list_all (λY. pdevs_domain (snd X) ∩ pdevs_domain (snd Y) = {}) XS"
    "e ∈ UNIV → {- 1..1}"
    "e' ∈ UNIV → {- 1..1}"
  have "⋀a b i. ∀Y∈set XS. pdevs_domain (snd X) ∩ pdevs_domain (snd Y) = {} ⟹
       pdevs_apply b i ≠ 0 ⟹
       pdevs_apply (snd X) i ≠ 0 ⟹
       (a, b) ∉ set XS"
    by (metis (poly_guards_query) IntI all_not_in_conv in_pdevs_domain snd_eqD)
  with H show
    "aform_val e' X # map (aform_val e) XS ∈ (λe. map (aform_val e) (X # XS)) ` (UNIV → {- 1..1})"
    by (intro image_eqI[where x = "λi. if i ∈ pdevs_domain (snd X) then e' i else e i"])
      (auto simp: aform_val_def list_all_iff Pi_iff intro!: pdevs_val_domain_cong)
qed


primrec approx_slp::"nat ⇒ slp ⇒ aform_err list ⇒ aform_err list option"
where
  "approx_slp p [] xs = Some xs"
| "approx_slp p (ea # eas) xs =
    do {
      r ← approx_floatarith p ea xs;
      approx_slp p eas (r#xs)
    }"

lemma Nil_mem_Joints[intro, simp]: "[] ∈ Joints []"
  by (force simp: Joints_def valuate_def)

lemma map_nth_Joints: "xs ∈ Joints XS ⟹ (⋀i. i ∈ set is ⟹ i < length XS) ⟹ map (nth xs) is @ xs ∈ Joints (map (nth XS) is @ XS)"
  by (auto simp: Joints_def valuate_def)

lemma map_nth_Joints': "xs ∈ Joints XS ⟹ (⋀i. i ∈ set is ⟹ i < length XS) ⟹ map (nth xs) is ∈ Joints (map (nth XS) is)"
  by (rule Joints_appendD2[OF map_nth_Joints]) auto

lemma approx_slp_Elem:
  assumes e: "e ∈ UNIV → {-1 .. 1}"
  assumes "vs ∈ aforms_err e VS"
  assumes "approx_slp p ra VS = Some X"
  shows "interpret_slp ra vs ∈ aforms_err e X"
  using assms(2-)
proof (induction ra arbitrary: X vs VS)
  case (Cons ra ras)
  from Cons.prems
  obtain a where a: "approx_floatarith p ra VS = Some a"
    and r: "approx_slp p ras (a # VS) = Some X"
    by (auto simp: bind_eq_Some_conv)
  from approx_floatarith_Elem[OF a e Cons.prems(1)]
  have "interpret_floatarith ra vs ∈ aform_err e a"
    by auto
  then have 1: "interpret_floatarith ra vs#vs ∈ aforms_err e (a#VS)"
    unfolding mem_aforms_err_Cons_iff
    using Cons.prems(1)
    by auto
  show ?case
    by (auto intro!: Cons.IH 1 r)
qed auto

definition "approx_slp_outer p n slp XS =
  do {
    let d = degree_aforms XS;
    let XSe = (map (λx. (x, 0)) XS);
    rs ← approx_slp p slp XSe;
    let rs' = take n rs;
    let d' = max d (degree_aforms_err rs');
    Some (aforms_err_to_aforms d' rs')
  }"

lemma take_in_listsetI: "xs ∈ listset XS ⟹ take n xs ∈ listset (take n XS)"
  by (induction XS arbitrary: xs n) (auto simp: take_Cons listset_Cons_mem_conv set_Cons_def split: nat.splits)

lemma take_in_aforms_errI: "take n xs ∈ aforms_err e (take n XS)"
  if "xs ∈ aforms_err e XS"
  using that
  by (auto simp: aforms_err_def take_map[symmetric] intro!: take_in_listsetI)

theorem approx_slp_outer:
  assumes "approx_slp_outer p n slp XS = Some RS"
  assumes slp: "slp = slp_of_fas fas" "n = length fas"
  assumes "xs ∈ Joints XS"
  shows "interpret_floatariths fas xs @ xs ∈ Joints (RS @ XS)"
proof -
  from assms obtain d XSe rs rs' d' where
    d: "d = degree_aforms XS"
    and XSe: "XSe = (map (λx. (x, 0)) XS)"
    and rs: "approx_slp p (slp_of_fas fas) XSe = Some rs"
    and rs': "rs' = take (length fas) rs"
    and d': "d' = max d (degree_aforms_err rs')"
    and RS: "aforms_err_to_aforms d' rs' = RS"
    by (auto simp: approx_slp_outer_def Let_def bind_eq_Some_conv)
  have abbd: "(a, b) ∈ set XS ⟹ degree b ≤ degree_aforms XS" for a b
    apply (rule degrees_leD[OF order_refl]) by force
  from d' d have i_less: "(a, b) ∈ set XS ⟹ i < degree b ⟹ i < min d d'" for i a b
    by (auto dest!: abbd)
  from assms obtain e' where vs: "xs = (map (aform_val e') XS)" and e': "e' ∈ UNIV → {-1 .. 1}"
    by (auto simp: Joints_def valuate_def)
  from d have d: "V ∈ set XS ⟹ degree_aform V ≤ d" for V
    by (auto intro!: degrees_leD)
  have xs_XSe: "xs ∈ aforms_err e' XSe"
    by (auto simp: vs aforms_err_def XSe o_def aform_err_def)
  from approx_slp_Elem[OF e' xs_XSe rs]
  have aforms_err: "interpret_slp (slp_of_fas fas) xs ∈ aforms_err e' rs" .
  have "interpret_floatariths fas xs = take (length fas) (interpret_slp (slp_of_fas fas) xs)"
    using assms by (simp add: slp_of_fas)
  also
  from aforms_err
  have "take (length fas) (interpret_slp (slp_of_fas fas) xs) ∈ aforms_err e' rs'"
    unfolding rs'
    by (auto simp: take_map intro!: take_in_aforms_errI)
  finally have ier: "interpret_floatariths fas xs ∈ aforms_err e' rs'" .
  have "degree_aforms_err rs' ≤ d'" using d' by auto
  from aforms_err_to_aformsE[OF ier this e'] obtain e where
    "interpret_floatariths fas xs = aform_vals e RS"
    and e: "e ∈ UNIV → {- 1..1}" "⋀i. i < d' ⟹ e i = e' i"
    unfolding RS
    by (auto simp: )
  moreover

  from e have e'_eq: "e' i = e i" if "i < min d d'" for i
    using that
    by (auto simp: min_def split: if_splits)
  then have "xs = aform_vals e XS"
    by (auto simp: vs aform_vals_def aform_val_def intro!: pdevs_val_degree_cong e'_eq i_less)

  ultimately show ?thesis
    using e(1)
    by (auto simp: Joints_def valuate_def aform_vals_def intro!: image_eqI[where x=e])

qed

theorem approx_slp_outer_plain:
  assumes "approx_slp_outer p n slp XS = Some RS"
  assumes slp: "slp = slp_of_fas fas" "n = length fas"
  assumes "xs ∈ Joints XS"
  shows "interpret_floatariths fas xs ∈ Joints RS"
proof -
  have "length fas = length RS"
  proof -
    have f1: "length xs = length XS"
      using Joints_imp_length_eq assms(4) by blast
    have "interpret_floatariths fas xs @ xs ∈ Joints (RS @ XS)"
      using approx_slp_outer assms(1) assms(2) assms(3) assms(4) by blast
    then show ?thesis
      using f1 Joints_imp_length_eq by fastforce
  qed
  with Joints_appendD2[OF approx_slp_outer[OF assms]] show ?thesis by simp
qed

end

end

Theory Counterclockwise_2D_Arbitrary

section ‹CCW for Arbitrary Points in the Plane›
theory Counterclockwise_2D_Arbitrary
imports Counterclockwise_2D_Strict
begin

subsection ‹Interpretation of Knuth's axioms in the plane›

definition lex::"point ⇒ point ⇒ bool" where
  "lex p q ⟷ (fst p < fst q ∨ fst p = fst q ∧ snd p < snd q ∨ p = q)"

definition psi::"point ⇒ point ⇒ point ⇒ bool" where
  "psi p q r ⟷ (lex p q ∧ lex q r)"

definition ccw::"point ⇒ point ⇒ point ⇒ bool" where
  "ccw p q r ⟷ ccw' p q r ∨ (det3 p q r = 0 ∧ (psi p q r ∨ psi q r p ∨ psi r p q))"

interpretation ccw: linorder_list0 "ccw x" for x .

lemma ccw'_imp_ccw: "ccw' a b c ⟹ ccw a b c"
  by (simp add: ccw_def)

lemma ccw_ncoll_imp_ccw: "ccw a b c ⟹ ¬coll a b c ⟹ ccw' a b c"
  by (simp add: ccw_def)

lemma ccw_translate: "ccw p (p + q) (p + r) = ccw 0 q r"
  by (auto simp: ccw_def psi_def lex_def)

lemma ccw_translate_origin: "NO_MATCH 0 p ⟹ ccw p q r = ccw 0 (q - p) (r - p)"
  using ccw_translate[of p "q - p" "r - p"]
  by simp

lemma psi_scale:
  "psi (r *⇩_R a) (r *⇩_R b) 0 = (if r > 0 then psi a b 0 else if r < 0 then psi 0 b a else True)"
  "psi (r *⇩_R a) 0 (r *⇩_R b) = (if r > 0 then psi a 0 b else if r < 0 then psi b 0 a else True)"
  "psi 0 (r *⇩_R a) (r *⇩_R b) = (if r > 0 then psi 0 a b else if r < 0 then psi b a 0 else True)"
  by (auto simp: psi_def lex_def det3_def' not_less algebra_split_simps)

lemma ccw_scale23: "ccw 0 a b ⟹ r > 0 ⟹ ccw 0 (r *⇩_R a) (r *⇩_R b)"
  by (auto simp: ccw_def psi_scale)

lemma psi_notI: "distinct3 p q r ⟹ psi p q r ⟹ ¬ psi q p r"
  by (auto simp: algebra_simps psi_def lex_def)

lemma not_lex_eq: "¬ lex a b ⟷ lex b a ∧ a ≠ b"
  by (auto simp: algebra_simps lex_def prod_eq_iff)

lemma lex_trans: "lex a b ⟹ lex b c ⟹ lex a c"
  by (auto simp: lex_def)

lemma lex_sym_eqI: "lex a b ⟹ lex b a ⟹ a = b"
  and lex_sym_eq_iff: "lex a b ⟹ lex b a ⟷ a = b"
  by (auto simp: lex_def)

lemma lex_refl[simp]: "lex p p"
  by (metis not_lex_eq)

lemma psi_disjuncts:
  "distinct3 p q r ⟹ psi p q r ∨ psi p r q ∨ psi q r p ∨ psi q p r ∨ psi r p q ∨ psi r q p"
  by (auto simp: psi_def not_lex_eq)

lemma nlex_ccw_left: "lex x 0 ⟹ ccw 0 (0, 1) x"
  by (auto simp: ccw_def lex_def psi_def ccw'_def det3_def')

interpretation ccw_system123 ccw
  apply unfold_locales
  subgoal by (force simp: ccw_def ccw'_def det3_def' algebra_simps)
  subgoal by (force simp: ccw_def ccw'_def det3_def' psi_def algebra_simps lex_sym_eq_iff)
  subgoal by (drule psi_disjuncts) (force simp: ccw_def ccw'_def det3_def' algebra_simps)
  done

lemma lex_scaleR_nonneg: "lex a b ⟹ r ≥ 0 ⟹ lex a (a + r *⇩_R (b - a))"
  by (auto simp: lex_def)

lemma lex_scale1_zero:
    "lex (v *⇩_R u) 0 = (if v > 0 then lex u 0 else if v < 0 then lex 0 u else True)"
  and lex_scale2_zero:
    "lex 0 (v *⇩_R u) = (if v > 0 then lex 0 u else if v < 0 then lex u 0 else True)"
  by (auto simp: lex_def prod_eq_iff less_eq_prod_def algebra_split_simps)

lemma nlex_add:
  assumes "lex a 0" "lex b 0"
  shows "lex (a + b) 0"
  using assms by (auto simp: lex_def)

lemma nlex_sum:
  assumes "finite X"
  assumes "⋀x. x ∈ X ⟹ lex (f x) 0"
  shows "lex (sum f X) 0"
  using assms
  by induction (auto intro!: nlex_add)

lemma abs_add_nlex:
  assumes "coll 0 a b"
  assumes "lex a 0"
  assumes "lex b 0"
  shows "abs (a + b) = abs a + abs b"
proof (rule antisym[OF abs_triangle_ineq])
  have "fst (¦a¦ + ¦b¦) ≤ fst ¦a + b¦"
    using assms
    by (auto simp add: det3_def' abs_prod_def lex_def)
  moreover
  {
    assume H: "fst a < 0" "fst b < 0"
    hence "snd b ≤ 0 ⟷ snd a ≤ 0"
      using assms
      by (auto simp: lex_def det3_def' mult.commute)
        (metis mult_le_cancel_left_neg mult_zero_right)+
    hence "¦snd a¦ + ¦snd b¦ ≤ ¦snd a + snd b¦"
      using H by auto
  } hence "snd (¦a¦ + ¦b¦) ≤ snd ¦a + b¦"
    using assms
    by (auto simp add: det3_def' abs_prod_def lex_def)
  ultimately
  show "¦a¦ + ¦b¦ ≤ ¦a + b¦" unfolding less_eq_prod_def ..
qed

lemma lex_sum_list: "(⋀x. x ∈ set xs ⟹ lex x 0) ⟹ lex (sum_list xs) 0"
  by (induct xs) (auto simp: nlex_add)

lemma
  abs_sum_list_coll:
  assumes coll: "list_all (coll 0 x) xs"
  assumes "x ≠ 0"
  assumes up: "list_all (λx. lex x 0) xs"
  shows "abs (sum_list xs) = sum_list (map abs xs)"
  using assms
proof (induct xs)
  case (Cons y ys)
  hence "coll 0 x y" "coll 0 x (sum_list ys)"
    by (auto simp: list_all_iff intro!: coll_sum_list)
  hence "coll 0 y (sum_list ys)" using ‹x ≠ 0›
    by (rule coll_trans)
  hence "¦y + sum_list ys¦ = abs y + abs (sum_list ys)" using Cons
    by (subst abs_add_nlex) (auto simp: list_all_iff lex_sum_list)
  thus ?case using Cons by simp
qed simp

lemma lex_diff1: "lex (a - b) c = lex a (c + b)"
  and lex_diff2: "lex c (a - b) = lex (c + b) a"
  by (auto simp: lex_def)

lemma sum_list_eq_0_iff_nonpos:
  fixes xs::"'a::ordered_ab_group_add list"
  shows "list_all (λx. x ≤ 0) xs ⟹ sum_list xs = 0 ⟷ (∀n∈set xs. n = 0)"
  by (auto simp: list_all_iff sum_list_sum_nth sum_nonpos_eq_0_iff)
    (auto simp add: in_set_conv_nth)

lemma sum_list_nlex_eq_zeroI:
  assumes nlex: "list_all (λx. lex x 0) xs"
  assumes "sum_list xs = 0"
  assumes "x ∈ set xs"
  shows "x = 0"
proof -
  from assms(2) have z1: "sum_list (map fst xs) = 0" and z2: "sum_list (map snd xs) = 0"
    by (auto simp: prod_eq_iff fst_sum_list snd_sum_list)
  from nlex have "list_all (λx. x ≤ 0) (map fst xs)"
    by (auto simp: lex_def list_all_iff)
  from sum_list_eq_0_iff_nonpos[OF this] z1 nlex
  have
    z1': "list_all (λx. x = 0) (map fst xs)"
    and "list_all (λx. x ≤ 0) (map snd xs)"
    by (auto simp: list_all_iff lex_def)
  from sum_list_eq_0_iff_nonpos[OF this(2)] z2
  have "list_all (λx. x = 0) (map snd xs)" by (simp add: list_all_iff)
  with z1' show "x = 0" by (auto simp: list_all_iff zero_prod_def assms prod_eq_iff)
qed

lemma sum_list_eq0I: "(∀x∈set xs. x = 0) ⟹ sum_list xs = 0"
  by (induct xs) auto

lemma sum_list_nlex_eq_zero_iff:
  assumes nlex: "list_all (λx. lex x 0) xs"
  shows "sum_list xs = 0 ⟷ list_all ((=) 0) xs"
  using assms
  by (auto intro: sum_list_nlex_eq_zeroI sum_list_eq0I simp: list_all_iff)

lemma
  assumes "lex p q" "lex q r" "0 ≤ a" "0 ≤ b" "0 ≤ c" "a + b + c = 1"
  assumes comb_def: "comb = a *⇩_R p + b *⇩_R q + c *⇩_R r"
  shows lex_convex3: "lex p comb" "lex comb r"
proof -
  from convex3_alt[OF assms(3-6), of p q r]
  obtain u v where
    uv: "a *⇩_R p + b *⇩_R q + c *⇩_R r = p + u *⇩_R (q - p) + v *⇩_R (r - p)" "0 ≤ u" "0 ≤ v" "u + v ≤ 1" .
  have "lex p r"
    using assms by (metis lex_trans)
  hence "lex (v *⇩_R (p - r)) 0" using uv
    by (simp add: lex_scale1_zero lex_diff1)
  also
  have "lex 0 (u *⇩_R (q - p))" using ‹lex p q› uv
    by (simp add: lex_scale2_zero lex_diff2)
  finally (lex_trans)
  show "lex p comb"
    unfolding comb_def uv
    by (simp add: lex_def prod_eq_iff algebra_simps)
  from comb_def have comb_def': "comb = c *⇩_R r + b *⇩_R q + a *⇩_R p" by simp
  from assms have "c + b + a = 1" by simp
  from convex3_alt[OF assms(5,4,3) this, of r q p]
  obtain u v where uv: "c *⇩_R r + b *⇩_R q + a *⇩_R p = r + u *⇩_R (q - r) + v *⇩_R (p - r)"
    "0 ≤ u" "0 ≤ v" "u + v ≤ 1"
    by auto
  have "lex (u *⇩_R (q - r)) 0"
    using uv ‹lex q r›
    by (simp add: lex_scale1_zero lex_diff1)
  also have "lex 0  (v *⇩_R (r - p))"
    using uv ‹lex p r›
    by (simp add: lex_scale2_zero lex_diff2)
  finally (lex_trans) show "lex comb r"
    unfolding comb_def' uv
    by (simp add: lex_def prod_eq_iff algebra_simps)
qed

lemma lex_convex_self2:
  assumes "lex p q" "0 ≤ a" "a ≤ 1"
  defines "r ≡ a *⇩_R p + (1 - a) *⇩_R q"
  shows "lex p r" (is ?th1)
    and "lex r q" (is ?th2)
  using lex_convex3[OF ‹lex p q›, of q a "1 - a" 0 r]
      assms
  by (simp_all add: r_def)

lemma lex_uminus0[simp]: "lex (-a) 0 = lex 0 a"
  by (auto simp: lex_def)

lemma
  lex_fst_zero_imp:
  "fst x = 0 ⟹ lex x 0 ⟹ lex y 0 ⟹ ¬coll 0 x y ⟹ ccw' 0 y x"
  by (auto simp: ccw'_def det3_def' lex_def algebra_split_simps)

lemma lex_ccw_left: "lex x y ⟹ r > 0 ⟹ ccw y (y + (0, r)) x"
  by (auto simp: ccw_def ccw'_def det3_def' algebra_simps lex_def psi_def)

lemma lex_translate_origin: "NO_MATCH 0 a ⟹ lex a b = lex 0 (b - a)"
  by (auto simp: lex_def)


subsection ‹Order prover setup›

definition "lexs p q ⟷ (lex p q ∧ p ≠ q)"

lemma lexs_irrefl: "¬ lexs p p"
  and lexs_imp_lex: "lexs x y ⟹ lex x y"
  and not_lexs: "(¬ lexs x y) = (lex y x)"
  and not_lex: "(¬ lex x y) = (lexs y x)"
  and eq_lex_refl: "x = y ⟹ lex x y"
  by (auto simp: lexs_def lex_def prod_eq_iff)

lemma lexs_trans: "lexs x y ⟹ lexs y z ⟹ lexs x z"
  and lexs_lex_trans: "lexs x y ⟹ lex y z ⟹ lexs x z"
  and lex_lexs_trans: "lex x y ⟹ lexs y z ⟹ lexs x z"
  and lex_neq_trans: "lex a b ⟹ a ≠ b ⟹ lexs a b"
  and neq_lex_trans: "a ≠ b ⟹ lex a b ⟹ lexs a b"
  and lexs_imp_neq: "lexs a b ⟹ a ≠ b"
  by (auto simp: lexs_def lex_def prod_eq_iff)

declare
  lexs_irrefl[THEN notE, order add less_reflE: linorder "(=) :: point => point => bool" lex lexs]
declare lex_refl[order add le_refl: linorder "(=) :: point => point => bool" lex lexs]
declare lexs_imp_lex[order add less_imp_le: linorder "(=) :: point => point => bool" lex lexs]
declare
  not_lexs[THEN iffD2, order add not_lessI: linorder "(=) :: point => point => bool" lex lexs]
declare not_lex[THEN iffD2, order add not_leI: linorder "(=) :: point => point => bool" lex lexs]
declare
  not_lexs[THEN iffD1, order add not_lessD: linorder "(=) :: point => point => bool" lex lexs]
declare not_lex[THEN iffD1, order add not_leD: linorder "(=) :: point => point => bool" lex lexs]
declare lex_sym_eqI[order add eqI: linorder "(=) :: point => point => bool" lex lexs]
declare eq_lex_refl[order add eqD1: linorder "(=) :: point => point => bool" lex lexs]
declare sym[THEN eq_lex_refl, order add eqD2: linorder "(=) :: point => point => bool" lex lexs]
declare lexs_trans[order add less_trans: linorder "(=) :: point => point => bool" lex lexs]
declare lexs_lex_trans[order add less_le_trans: linorder "(=) :: point => point => bool" lex lexs]
declare lex_lexs_trans[order add le_less_trans: linorder "(=) :: point => point => bool" lex lexs]
declare lex_trans[order add le_trans: linorder "(=) :: point => point => bool" lex lexs]
declare lex_neq_trans[order add le_neq_trans: linorder "(=) :: point => point => bool" lex lexs]
declare neq_lex_trans[order add neq_le_trans: linorder "(=) :: point => point => bool" lex lexs]
declare lexs_imp_neq[order add less_imp_neq: linorder "(=) :: point => point => bool" lex lexs]
declare
  eq_neq_eq_imp_neq[order add eq_neq_eq_imp_neq: linorder "(=) :: point => point => bool" lex lexs]
declare not_sym[order add not_sym: linorder "(=) :: point => point => bool" lex lexs]


subsection ‹Contradictions›

lemma
  assumes d: "distinct4 s p q r"
  shows contra1: "¬(lex p q ∧ lex q r ∧ lex r s ∧ indelta s p q r)" (is ?th1)
    and contra2: "¬(lex s p ∧ lex p q ∧ lex q r ∧ indelta s p q r)" (is ?th2)
    and contra3: "¬(lex p r ∧ lex p s ∧ lex q r ∧ lex q s ∧ insquare p r q s)" (is ?th3)
proof -
  {
    assume "det3 s p q = 0" "det3 s q r = 0" "det3 s r p = 0" "det3 p q r = 0"
    hence ?th1 ?th2 ?th3 using d
      by (auto simp add: det3_def' ccw'_def ccw_def psi_def algebra_simps)
  } moreover {
    assume *: "¬(det3 s p q = 0 ∧ det3 s q r = 0 ∧ det3 s r p = 0 ∧ det3 p q r = 0)"
    {
      assume d0: "det3 p q r = 0"
      with d have "?th1 ∧ ?th2"
        by (force simp add: det3_def' ccw'_def ccw_def psi_def algebra_simps)
    } moreover {
      assume dp: "det3 p q r ≠ 0"
      have "?th1 ∧ ?th2"
        unfolding de_Morgan_disj[symmetric]
      proof (rule notI, goal_cases)
        case prems: 1
        hence **: "indelta s p q r" by auto
        hence nonnegs: "det3 p q r ≥ 0" "0 ≤ det3 s q r" "0 ≤ det3 p s r" "0 ≤ det3 p q s"
          by (auto simp: ccw_def ccw'_def det3_def' algebra_simps)
        hence det_pos: "det3 p q r > 0" using dp by simp
        have det_eq: "det3 s q r + det3 p s r + det3 p q s = det3 p q r"
          by (auto simp: ccw_def det3_def' algebra_simps)
        hence det_div_eq:
          "det3 s q r / det3 p q r + det3 p s r / det3 p q r + det3 p q s / det3 p q r = 1"
          using det_pos by (auto simp: field_simps)
        from lex_convex3[OF _ _ _ _ _ det_div_eq convex_comb_dets[OF det_pos, of s]]
        have "lex p s" "lex s r"
          using prems by (auto simp: nonnegs)
        with prems d show False by (simp add: lex_sym_eq_iff)
      qed
    } moreover have ?th3
    proof (safe, goal_cases)
      case prems: 1
      have nonnegs: "det3 p r q ≥ 0" "det3 r q s ≥ 0" "det3 s p r ≥ 0" "det3 q s p ≥ 0"
        using prems
        by (auto simp add: ccw_def ccw'_def less_eq_real_def)
      have dets_eq: "det3 p r q + det3 q s p = det3 r q s + det3 s p r"
        by (auto simp: det3_def')
      hence **: "det3 p r q = 0 ∧ det3 q s p = 0 ⟹ det3 r q s = 0 ∧ det3 s p r = 0"
        using prems
        by (auto simp: ccw_def ccw'_def)
      moreover
      {
        fix p r q s
        assume det_pos: "det3 p r q > 0"
        assume dets_eq: "det3 p r q + det3 q s p = det3 r q s + det3 s p r"
        assume nonnegs:"det3 r q s ≥ 0" "det3 s p r ≥ 0" "det3 q s p ≥ 0"
        assume g14: "lex p r" "lex p s" "lex q r" "lex q s"
        assume d: "distinct4 s p q r"

        let ?sum = "(det3 p r q + det3 q s p) / det3 p r q"
        have eqs: "det3 s p r = det3 p r s" "det3 r q s = det3 s r q" "det3 q s p = - det3 p s q"
          by (auto simp: det3_def' algebra_simps)
        from convex_comb_dets[OF det_pos, of s]
        have "((det3 p r q / det3 p r q) *⇩_R s + (det3 q s p / det3 p r q) *⇩_R r) /⇩_R ?sum =
            ((det3 r q s / det3 p r q) *⇩_R p + (det3 s p r / det3 p r q) *⇩_R q) /⇩_R ?sum"
          unfolding eqs
          by (simp add: algebra_simps prod_eq_iff)
        hence srpq: "(det3 p r q / det3 p r q / ?sum) *⇩_R s + (det3 q s p / det3 p r q / ?sum) *⇩_R r =
          (det3 r q s / det3 p r q / ?sum) *⇩_R p + (det3 s p r / det3 p r q  / ?sum) *⇩_R q"
          (is "?s *⇩_R s + ?r *⇩_R r = ?p *⇩_R p + ?q *⇩_R q")
          using det_pos
          by (simp add: algebra_simps inverse_eq_divide)
        have eqs: "?s + ?r = 1" "?p + ?q = 1"
          and s: "?s ≥ 0" "?s ≤ 1"
          and r: "?r ≥ 0" "?r ≤ 1"
          and p: "?p ≥ 0" "?p ≤ 1"
          and q: "?q ≥ 0" "?q ≤ 1"
          unfolding add_divide_distrib[symmetric]
          using det_pos nonnegs dets_eq
          by (auto)
        from eqs have eqs': "1 - ?s = ?r" "1 - ?r = ?s" "1 - ?p = ?q" "1 - ?q = ?p"
          by auto
        have comm: "?r *⇩_R r + ?s *⇩_R s = ?s *⇩_R s + ?r *⇩_R r"
          "?q *⇩_R q + ?p *⇩_R p = ?p *⇩_R p + ?q *⇩_R q"
          by simp_all
        define K
          where "K = (det3 r q s / det3 p r q / ?sum) *⇩_R p + (det3 s p r / det3 p r q  / ?sum) *⇩_R q"
        note rewrs = eqs' comm srpq K_def[symmetric]
        from lex_convex_self2[OF _ s, of s r, unfolded rewrs]
           lex_convex_self2[OF _ r, of r s, unfolded rewrs]
           lex_convex_self2[OF _ p, of p q, unfolded rewrs]
           lex_convex_self2[OF _ q, of q p, unfolded rewrs]
        have False using g14 d det_pos
          by (metis lex_trans not_lex_eq)
      } note wlog = this
      from dets_eq have 1: "det3 q s p + det3 p r q = det3 s p r + det3 r q s"
        by simp
      from d have d': "distinct4 r q p s" by auto
      note wlog[of q s p r, OF _ 1 nonnegs(3,2,1) prems(4,3,2,1) d']
        wlog[of p r q s, OF _ dets_eq nonnegs(2,3,4) prems(1-4) d]
      ultimately show False using nonnegs d *
        by (auto simp: less_eq_real_def det3_def' algebra_simps)
    qed
    ultimately have ?th1 ?th2 ?th3 by blast+
  } ultimately show ?th1 ?th2 ?th3 by force+
qed

lemma ccw'_subst_psi_disj:
  assumes "det3 t r s = 0"
  assumes "psi t r s ∨ psi t s r ∨ psi s r t"
  assumes "s ≠ t"
  assumes "ccw' t r p"
  shows "ccw' t s p"
proof cases
  assume "r ≠ s"
  from assms have "r ≠ t" by (auto simp: det3_def' ccw'_def algebra_simps)
  from assms have "det3 r s t = 0"
    by (auto simp: algebra_simps det3_def')
  from coll_ex_scaling[OF assms(3) this]
  obtain x where s: "r = s + x *⇩_R (t - s)" by auto
  from assms(4)[simplified s]
  have "0 < det3 0 (s + x *⇩_R (t - s) - t) (p - t)"
    by (auto simp: algebra_simps det3_def' ccw'_def)
  also have "s + x *⇩_R (t - s) - t = (1 - x) *⇩_R (s - t)"
    by (simp add: algebra_simps)
  finally have ccw': "ccw' 0 ((1 - x) *⇩_R (s - t)) (p - t)"
    by (simp add: ccw'_def)
  hence neq: "x ≠ 1" by (auto simp add: det3_def' ccw'_def)
  have tr: "fst s < fst r ⟹ fst t = fst s ⟹ snd t ≤ snd r"
    by (simp add: s)
  from s have "fst (r - s) = fst (x *⇩_R (t - s))" "snd (r - s) = snd (x *⇩_R (t - s))"
    by (auto simp: )
  hence "x = (if fst (t - s) = 0 then snd (r - s) / snd (t - s) else fst (r - s) / fst (t - s))"
    using ‹s ≠ t›
    by (auto simp add: field_simps prod_eq_iff)
  also have "… ≤ 1"
    using assms
    by (auto simp: lex_def psi_def tr)
  finally have "x < 1" using neq by simp
  thus ?thesis using ccw'
    by (auto simp: ccw'.translate_origin)
qed (insert assms, simp)

lemma lex_contr:
  assumes "distinct4 t s q r"
  assumes "lex t s" "lex s r"
  assumes "det3 t s r = 0"
  assumes "ccw' t s q"
  assumes "ccw' t q r"
  shows "False"
  using ccw'_subst_psi_disj[of t s r q] assms
  by (cases "r = t") (auto simp: det3_def' algebra_simps psi_def ccw'_def)

lemma contra4:
  assumes "distinct4 s r q p"
  assumes lex: "lex q p" "lex p r" "lex r s"
  assumes ccw: "ccw r q s" "ccw r s p" "ccw r q p"
  shows False
proof cases
  assume c: "ccw s q p"
  from c have *: "indelta s r q p"
    using assms by simp
  with contra1[OF assms(1)]
  have "¬ (lex r q ∧ lex q p ∧ lex p s)" by blast
  hence "¬ lex q p"
    using ‹ccw s q p› contra1 cyclic assms nondegenerate by blast
  thus False using assms by simp
next
  assume "¬ ccw s q p"
  with ccw have "ccw q s p ∧ ccw s p r ∧ ccw p r q ∧ ccw r q s"
    by (metis assms(1) ccw'.cyclic ccw_def not_ccw'_eq psi_disjuncts)
  moreover
  from lex have "lex q r" "lex q s" "lex p r" "lex p s" by order+
  ultimately show False using contra3[of r q p s] ‹distinct4 s r q p› by blast
qed

lemma not_coll_ordered_lexI:
  assumes "l ≠ x0"
    and "lex x1 r"
    and "lex x1 l"
    and "lex r x0"
    and "lex l x0"
    and "ccw' x0 l x1"
    and "ccw' x0 x1 r"
  shows "det3 x0 l r ≠ 0"
proof
  assume "coll x0 l r"
  from ‹coll x0 l r› have 1: "coll 0 (l - x0) (r - x0)"
    by (simp add: det3_def' algebra_simps)
  from ‹lex r x0› have 2: "lex (r - x0) 0" by (auto simp add: lex_def)
  from ‹lex l x0› have 3: "lex (l - x0) 0" by (auto simp add: lex_def)
  from ‹ccw' x0 l x1› have 4: "ccw' 0 (l - x0) (x1 - x0)"
    by (simp add: det3_def' ccw'_def algebra_simps)
  from ‹ccw' x0 x1 r› have 5: "ccw' 0 (x1 - x0) (r - x0)"
    by (simp add: det3_def' ccw'_def algebra_simps)
  from ‹lex x1 r› have 6: "lex 0 (r - x0 - (x1 - x0))" by (auto simp: lex_def)
  from ‹lex x1 l› have 7: "lex 0 (l - x0 - (x1 - x0))" by (auto simp: lex_def)
  define r' where "r' = r - x0"
  define l' where "l' = l - x0"
  define x0' where "x0' = x1 - x0"
  from 1 2 3 4 5 6 7
  have rs: "coll 0 l' r'" "lex r' 0"
    "lex l' 0"
    "ccw' 0 l' x0'"
    "ccw' 0 x0' r'"
    "lex 0 (r' - x0')"
    "lex 0 (l' - x0')"
    unfolding r'_def[symmetric] l'_def[symmetric] x0'_def[symmetric]
    by auto
  from assms have "l' ≠ 0"
    by (auto simp: l'_def)
  from coll_scale[OF ‹coll 0 l' _› this]
  obtain y where y: "r' = y *⇩_R l'" by auto
  {
    assume "y > 0"
    with rs have False
      by (auto simp: det3_def' algebra_simps y ccw'_def)
  } moreover {
    assume "y < 0"
    with rs have False
      by (auto simp: lex_def not_less algebra_simps algebra_split_simps y ccw'_def)
  } moreover {
    assume "y = 0"
    from this rs have False
      by (simp add: ccw'_def y)
  } ultimately show False by arith
qed

interpretation ccw_system4 ccw
proof unfold_locales
  fix p q r t
  assume ccw: "ccw t q r" "ccw p t r" "ccw p q t"
  show "ccw p q r"
  proof (cases "det3 t q r = 0 ∧ det3 p t r = 0 ∧ det3 p q t = 0")
    case True
    {
      assume "psi t q r ∨ psi q r t ∨ psi r t q"
        "psi p t r ∨ psi t r p ∨ psi r p t"
        "psi p q t ∨ psi q t p ∨ psi t p q"
      hence "psi p q r ∨ psi q r p ∨ psi r p q"
        using lex_sym_eq_iff psi_def by blast
    }
    with True ccw show ?thesis
      by (simp add: det3_def' algebra_simps ccw_def ccw'_def)
  next
    case False
    hence "0 ≤ det3 t q r" "0 ≤ det3 p t r" "0 ≤ det3 p q t"
      using ccw by (auto simp: less_eq_real_def ccw_def ccw'_def)
    with False show ?thesis
      by (auto simp: ccw_def det3_def' algebra_simps ccw'_def intro!: disjI1)
  qed
qed

lemma lex_total: "lex t q ∧ t ≠ q ∨ lex q t ∧ t ≠ q ∨ t = q"
  by auto

lemma
  ccw_two_up_contra:
  assumes c: "ccw' t p q" "ccw' t q r"
  assumes ccws: "ccw t s p" "ccw t s q" "ccw t s r" "ccw t p q" "ccw t q r" "ccw t r p"
  assumes distinct: "distinct5 t s p q r"
  shows False
proof -
  from ccws
  have nn: "det3 t s p ≥ 0" "det3 t s q ≥ 0" "det3 t s r ≥ 0" "det3 t r p ≥ 0"
    by (auto simp add: less_eq_real_def ccw_def ccw'_def)
  with c det_identity[of t p q s r]
  have tsr: "coll t s r" and tsp: "coll t s p"
    by (auto simp: add_nonneg_eq_0_iff ccw'_def)
  moreover
  have trp: "coll t r p"
    by (metis ccw'_subst_collinear distinct not_ccw'_eq tsr tsp)
  ultimately have tpr: "coll t p r"
    by (auto simp: det3_def' algebra_simps)
  moreover
  have psi: "psi t p r ∨ psi t r p ∨ psi r p t"
    unfolding psi_def
  proof -
    have ntsr: "¬ ccw' t s r" "¬ ccw' t r s"
      using tsr
      by (auto simp: not_ccw'_eq det3_def' algebra_simps)
    have f8: "¬ ccw' t r s"
      using tsr not_ccw'_eq by blast
    have f9: "¬ ccw' t r p"
      using tpr by (simp add: not_ccw'_eq)
    have f10: "(lex t r ∧ lex r p ∨ lex r p ∧ lex p t ∨ lex p t ∧ lex t r)"
      using ccw_def ccws(6) psi_def f9 by auto

    have "¬ ccw' t r q"
      using c(2) not_ccw'_eq by blast
    moreover
    have "¬coll t q s"
      using ntsr ccw'_subst_collinear distinct c(2) by blast
    hence "ccw' t s q"
      by (meson ccw_def ccws(2) not_ccw'_eq)
    moreover
    from tsr tsp ‹coll t r p› have "coll t p s" "coll t p r" "coll t r s"
      by (auto simp add: det3_def' algebra_simps)
    ultimately
    show "lex t p ∧ lex p r ∨ lex t r ∧ lex r p ∨ lex r p ∧ lex p t"
      by (metis ccw'_subst_psi_disj distinct ccw_def ccws(3) contra4 tsp ntsr(1) f10 lex_total
        psi_def trp)
  qed
  moreover
  from distinct have "r ≠ t" by auto
  ultimately
  have "ccw' t r q" using c(1)
    by (rule ccw'_subst_psi_disj)
  thus False
    using c(2) by (simp add: ccw'_contra)
qed

lemma
  ccw_transitive_contr:
  fixes t s p q r
  assumes ccws: "ccw t s p" "ccw t s q" "ccw t s r" "ccw t p q" "ccw t q r" "ccw t r p"
  assumes distinct: "distinct5 t s p q r"
  shows False
proof -
  from ccws distinct have *: "ccw p t r" "ccw p q t" by (metis cyclic)+
  with distinct have "ccw r p q" using interior[OF _ _ ccws(5) *, of UNIV]
    by (auto intro: cyclic)

  from ccws have nonnegs: "det3 t s p ≥ 0" "det3 t s q ≥ 0" "det3 t s r ≥ 0" "det3 t p q ≥ 0"
    "det3 t q r ≥ 0" "det3 t r p ≥ 0"
    by (auto simp add: less_eq_real_def ccw_def ccw'_def)
  {
    assume "ccw' t p q" "ccw' t q r" "ccw' t r p"
    hence False
      using ccw_two_up_contra ccws distinct by blast
  } moreover {
    assume c: "coll t q r" "coll t r p"
    with distinct four_points_aligned(1)[OF c, of s]
    have "coll t p q"
      by auto
    hence "(psi t p q ∨ psi p q t ∨ psi q t p)"
      "psi t q r ∨ psi q r t ∨ psi r t q"
      "psi t r p ∨ psi r p t ∨ psi p t r"
      using ccws(4,5,6) c
      by (simp_all add: ccw_def ccw'_def)
    hence False
      using distinct
      by (auto simp: psi_def ccw'_def)
  } moreover {
    assume c: "det3 t p q = 0" "det3 t q r > 0" "det3 t r p = 0"
    have "⋀x. det3 t q r = 0 ∨ t = x ∨ r = q ∨ q = x ∨ r = p ∨ p = x ∨ r = x"
      by (meson c(1) c(3) distinct four_points_aligned(1))
    hence False
      by (metis (full_types) c(2) distinct less_irrefl)
  } moreover {
    assume c: "det3 t p q = 0" "det3 t q r = 0" "det3 t r p > 0"
    have "⋀x. det3 t r p = 0 ∨ t = x ∨ r = x ∨ q = x ∨ p = x"
      by (meson c(1) c(2) distinct four_points_aligned(1))
    hence False
      by (metis (no_types) c(3) distinct less_numeral_extra(3))
  } moreover {
    assume c: "ccw' t p q" "ccw' t q r"
    from ccw_two_up_contra[OF this ccws distinct]
    have False .
  } moreover {
    assume c: "ccw' t p q" "ccw' t r p"
    from ccw_two_up_contra[OF this(2,1), of s] ccws distinct
    have False by auto
  } moreover {
    assume c: "ccw' t q r" "ccw' t r p"
    from ccw_two_up_contra[OF this, of s] ccws distinct
    have False by auto
  } ultimately show "False"
    using ‹0 ≤ det3 t p q›
    ‹0 ≤ det3 t q r›‹0 ≤ det3 t r p›
    by (auto simp: less_eq_real_def ccw'_def)
qed

interpretation ccw: ccw_system ccw
  by unfold_locales (metis ccw_transitive_contr nondegenerate)

lemma ccw_scaleR1:
  "det3 0 xr P ≠ 0 ⟹ 0 < e ⟹ ccw 0 xr P ⟹ ccw 0 (e*⇩_Rxr) P"
  by (simp add: ccw_def)

lemma ccw_scaleR2:
  "det3 0 xr P ≠ 0 ⟹ 0 < e ⟹ ccw 0 xr P ⟹ ccw 0 xr (e*⇩_RP)"
  by (simp add: ccw_def)

lemma ccw_translate3_aux:
  assumes "¬coll 0 a b"
  assumes "x < 1"
  assumes "ccw 0 (a - x*⇩_Ra) (b - x *⇩_R a)"
  shows "ccw 0 a b"
proof -
  from assms have "¬ coll 0 (a - x*⇩_Ra) (b - x *⇩_R a)"
    by simp
  with assms have "ccw' 0 ((1 - x) *⇩_R a) (b - x *⇩_R a)"
    by (simp add: algebra_simps ccw_def)
  thus "ccw 0 a b"
    using ‹x < 1›
    by (simp add: ccw_def)
qed

lemma ccw_translate3_minus: "det3 0 a b ≠ 0 ⟹ x < 1 ⟹ ccw 0 a (b - x *⇩_R a) ⟹ ccw 0 a b"
  using ccw_translate3_aux[of a b x] ccw_scaleR1[of a "b - x *⇩_R a" "1-x" ]
  by (auto simp add: algebra_simps)

lemma ccw_translate3: "det3 0 a b ≠ 0 ⟹ x < 1 ⟹ ccw 0 a b ⟹ ccw 0 a (x *⇩_R a + b)"
  by (rule ccw_translate3_minus) (auto simp add: algebra_simps)

lemma ccw_switch23: "det3 0 P Q ≠ 0 ⟹ (¬ ccw 0 Q P ⟷ ccw 0 P Q)"
  by (auto simp: ccw_def algebra_simps not_ccw'_eq ccw'_not_coll)

lemma ccw0_upward: "fst a > 0 ⟹ snd a = 0 ⟹ snd b > snd a ⟹ ccw 0 a b"
  by (auto simp: ccw_def det3_def' algebra_simps ccw'_def)

lemma ccw_uminus3[simp]: "det3 a b c ≠ 0 ⟹ ccw (-a) (-b) (-c) = ccw a b c"
  by (auto simp: ccw_def ccw'_def algebra_simps det3_def')

lemma coll_minus_eq: "coll (x - a) (x - b) (x - c) = coll a b c"
  by (auto simp: det3_def' algebra_simps)

lemma ccw_minus3: "¬ coll a b c ⟹ ccw (x - a) (x - b) (x - c) ⟷ ccw a b c"
  by (simp add: ccw_def coll_minus_eq)

lemma ccw0_uminus[simp]: "¬ coll 0 a b ⟹ ccw 0 (-a) (-b) ⟷ ccw 0 a b"
  using ccw_uminus3[of 0 a b]
  by simp

lemma lex_convex2:
  assumes "lex p q" "lex p r" "0 ≤ u" "u ≤ 1"
  shows "lex p (u *⇩_R q + (1 - u) *⇩_R r)"
proof cases
  note ‹lex p q›
  also
  assume "lex q r"
  hence "lex q (u *⇩_R q + (1 - u) *⇩_R r)"
    using ‹0 ≤ u› ‹u ≤ 1›
    by (rule lex_convex_self2)
  finally (lex_trans) show ?thesis .
next
  note ‹lex p r›
  also
  assume "¬ lex q r"
  hence "lex r q"
    by simp
  hence "lex r ((1 - u) *⇩_R r + (1 - (1 - u)) *⇩_R q)"
    using ‹0 ≤ u› ‹u ≤ 1›
    by (intro lex_convex_self2) simp_all
  finally (lex_trans) show ?thesis by (simp add: ac_simps)
qed

lemma lex_convex2':
  assumes "lex q p" "lex r p" "0 ≤ u" "u ≤ 1"
  shows "lex (u *⇩_R q + (1 - u) *⇩_R r) p"
proof -
  have "lex (- p) (u *⇩_R (-q) + (1 - u) *⇩_R (-r))"
    using assms
    by (intro lex_convex2) (auto simp: lex_def)
  thus ?thesis
    by (auto simp: lex_def algebra_simps)
qed

lemma psi_convex1:
  assumes "psi c a b"
  assumes "psi d a b"
  assumes "0 ≤ u" "0 ≤ v" "u + v = 1"
  shows "psi (u *⇩_R c + v *⇩_R d) a b"
proof -
  from assms have v: "v = (1 - u)" by simp
  show ?thesis
    using assms
    by (auto simp: psi_def v intro!: lex_convex2' lex_convex2)
qed

lemma psi_convex2:
  assumes "psi a c b"
  assumes "psi a d b"
  assumes "0 ≤ u" "0 ≤ v" "u + v = 1"
  shows "psi a (u *⇩_R c + v *⇩_R d) b"
proof -
  from assms have v: "v = (1 - u)" by simp
  show ?thesis
    using assms
    by (auto simp: psi_def v intro!: lex_convex2' lex_convex2)
qed

lemma psi_convex3:
  assumes "psi a b c"
  assumes "psi a b d"
  assumes "0 ≤ u" "0 ≤ v" "u + v = 1"
  shows "psi a b (u *⇩_R c + v *⇩_R d)"
proof -
  from assms have v: "v = (1 - u)" by simp
  show ?thesis
    using assms
    by (auto simp: psi_def v intro!: lex_convex2)
qed

lemma coll_convex:
  assumes "coll a b c" "coll a b d"
  assumes "0 ≤ u" "0 ≤ v" "u + v = 1"
  shows "coll a b (u *⇩_R c + v *⇩_R d)"
proof cases
  assume "a ≠ b"
  with assms(1, 2)
  obtain x y where xy: "c - a = x *⇩_R (b - a)" "d - a = y *⇩_R (b - a)"
    by (auto simp: det3_translate_origin dest!: coll_scale)
  from assms have "(u + v) *⇩_R a = a" by simp
  hence "u *⇩_R c + v *⇩_R d - a = u *⇩_R (c - a) + v *⇩_R (d - a)"
    by (simp add: algebra_simps)
  also have "… = u *⇩_R x *⇩_R (b - a) + v *⇩_R y *⇩_R (b - a)"
    by (simp add: xy)
  also have "… = (u * x + v * y) *⇩_R (b - a)" by (simp add: algebra_simps)
  also have "coll 0 (b - a) …"
    by (simp add: coll_scaleR_right_eq)
  finally show ?thesis
    by (auto simp: det3_translate_origin)
qed simp

lemma (in ccw_vector_space) convex3:
  assumes "u ≥ 0" "v ≥ 0" "u + v = 1" "ccw a b d" "ccw a b c"
  shows "ccw a b (u *⇩_R c + v *⇩_R d)"
proof -
  have "v = 1 - u" using assms by simp
  hence "ccw 0 (b - a) (u *⇩_R (c - a) + v *⇩_R (d - a))"
    using assms
    by (cases "u = 0" "v = 0" rule: bool.exhaust[case_product bool.exhaust])
      (auto simp add: translate_origin intro!: add3)
  also
  have "(u + v) *⇩_R a = a" by (simp add: assms)
  hence "u *⇩_R (c - a) + v *⇩_R (d - a) = u *⇩_R c + v *⇩_R d - a"
    by (auto simp: algebra_simps)
  finally show ?thesis by (simp add: translate_origin)
qed

lemma ccw_self[simp]: "ccw a a b" "ccw b a a"
  by (auto simp: ccw_def psi_def intro: cyclic)

lemma ccw_sefl'[simp]: "ccw a b a"
  by (rule cyclic) simp

lemma ccw_convex':
  assumes uv: "u ≥ 0" "v ≥ 0" "u + v = 1"
  assumes "ccw a b c" and 1: "coll a b c"
  assumes "ccw a b d" and 2: "¬ coll a b d"
  shows "ccw a b (u *⇩_R c + v *⇩_R d)"
proof -
  from assms have u: "0 ≤ u" "u ≤ 1" and v: "v = 1 - u"
    by (auto simp: algebra_simps)
  let ?c = "u *⇩_R c + v *⇩_R d"
  from 1 have abd: "ccw' a b d"
    using assms by (auto simp: ccw_def)
  {
    assume 2: "¬ coll a b c"
    from 2 have "ccw' a b c"
      using assms by (auto simp: ccw_def)
    with abd have "ccw' a b ?c"
      using assms by (auto intro!: ccw'.convex3)
    hence ?thesis
      by (simp add: ccw_def)
  } moreover {
    assume 2: "coll a b c"
    {
      assume "a = b"
      hence ?thesis by simp
    } moreover {
      assume "v = 0"
      hence ?thesis
        by (auto simp: v assms)
    } moreover {
      assume "v ≠ 0" "a ≠ b"
      have "coll c a b" using 2 by (auto simp: det3_def' algebra_simps)
      from coll_ex_scaling[OF ‹a ≠ b› this]
      obtain r where c: "c = a + r *⇩_R (b - a)" by auto
      have *: "u *⇩_R (a + r *⇩_R (b - a)) + v *⇩_R d - a = (u * r) *⇩_R (b - a)  + (1 - u) *⇩_R (d - a)"
        by (auto simp: algebra_simps v)
      have "ccw' a b ?c"
        using ‹v ≠ 0› uv abd
        by (simp add: ccw'.translate_origin c *)
      hence ?thesis by (simp add: ccw_def)
    } ultimately have ?thesis by blast
  } ultimately show ?thesis by blast
qed

lemma ccw_convex:
  assumes uv: "u ≥ 0" "v ≥ 0" "u + v = 1"
  assumes "ccw a b c"
  assumes "ccw a b d"
  assumes lex: "coll a b c ⟹ coll a b d ⟹ lex b a"
  shows "ccw a b (u *⇩_R c + v *⇩_R d)"
proof -
  from assms have u: "0 ≤ u" "u ≤ 1" and v: "v = 1 - u"
    by (auto simp: algebra_simps)
  let ?c = "u *⇩_R c + v *⇩_R d"
  {
    assume coll: "coll a b c ∧ coll a b d"
    hence "coll a b ?c"
      by (auto intro!: coll_convex assms)
    moreover
    from coll have "psi a b c ∨ psi b c a ∨ psi c a b" "psi a b d ∨ psi b d a ∨ psi d a b"
      using assms by (auto simp add: ccw_def ccw'_not_coll)
    hence "psi a b ?c ∨ psi b ?c a ∨ psi ?c a b"
      using coll uv lex
      by (auto simp: psi_def ccw_def not_lex lexs_def v intro: lex_convex2 lex_convex2')
    ultimately have ?thesis
      by (simp add: ccw_def)
  } moreover {
    assume 1: "¬ coll a b d" and 2: "¬ coll a b c"
    from 1 have abd: "ccw' a b d"
      using assms by (auto simp: ccw_def)
    from 2 have "ccw' a b c"
      using assms by (auto simp: ccw_def)
    with abd have "ccw' a b ?c"
      using assms by (auto intro!: ccw'.convex3)
    hence ?thesis
      by (simp add: ccw_def)
  } moreover {
    assume "¬ coll a b d" "coll a b c"
    have ?thesis
      by (rule ccw_convex') fact+
  } moreover {
    assume 1: "coll a b d" and 2: "¬ coll a b c"
    have "0 ≤ 1 - u" using assms by (auto )
    from ccw_convex'[OF this ‹0 ≤ u› _ ‹ccw a b d› 1 ‹ccw a b c› 2]
    have ?thesis by (simp add: algebra_simps v)
  } ultimately show ?thesis by blast
qed

interpretation ccw: ccw_convex ccw S "λa b. lex b a" for S
  by unfold_locales (rule ccw_convex)

lemma ccw_sorted_scaleR: "ccw.sortedP 0 xs ⟹ r > 0 ⟹ ccw.sortedP 0 (map ((*⇩_R) r) xs)"
  by (induct xs)
    (auto intro!: ccw.sortedP.Cons ccw_scale23 elim!: ccw.sortedP_Cons simp del: scaleR_Pair)

lemma ccw_sorted_implies_ccw'_sortedP:
  assumes nonaligned: "⋀y z. y ∈ set Ps ⟹ z ∈ set Ps ⟹ y ≠ z ⟹ ¬ coll 0 y z"
  assumes sorted: "linorder_list0.sortedP (ccw 0) Ps"
  assumes "distinct Ps"
  shows "linorder_list0.sortedP (ccw' 0 ) Ps"
  using assms
proof (induction Ps)
  case (Cons P Ps)
  {
    fix p assume p: "p ∈ set Ps"
    moreover
    from p Cons.prems have "ccw 0 P p"
      by (auto elim!: linorder_list0.sortedP_Cons intro: Cons)
    ultimately
    have "ccw' 0 P p"
      using ‹distinct (P#Ps)›
      by (intro ccw_ncoll_imp_ccw Cons) auto
  }
  moreover
  have "linorder_list0.sortedP (ccw' 0) Ps"
    using Cons.prems
    by (intro Cons) (auto elim!: linorder_list0.sortedP_Cons intro: Cons)
  ultimately
  show ?case
    by (auto intro!: linorder_list0.Cons )
qed (auto intro: linorder_list0.Nil)

end

Theory Intersection

section ‹Intersection›
theory Intersection
imports
  "HOL-Library.Monad_Syntax"
  Polygon
  Counterclockwise_2D_Arbitrary
  Affine_Form
begin
text ‹\label{sec:intersection}›

subsection ‹Polygons and @{term ccw}, @{term lex}, @{term psi}, @{term coll}›

lemma polychain_of_ccw_conjunction:
  assumes sorted: "ccw'.sortedP 0 Ps"
  assumes z: "z ∈ set (polychain_of Pc Ps)"
  shows "list_all (λ(xi, xj). ccw xi xj (fst z) ∧ ccw xi xj (snd z)) (polychain_of Pc Ps)"
  using assms
proof (induction Ps arbitrary: Pc z rule: list.induct)
  case (Cons P Ps)
  {
    assume "set Ps = {}"
    hence ?case using Cons by simp
  } moreover {
    assume "set Ps ≠ {}"
    hence "Ps ≠ []" by simp
    {
      fix a assume "a ∈ set Ps"
      hence "ccw' 0 P a"
        using Cons.prems
        by (auto elim!: linorder_list0.sortedP_Cons)
    } note ccw' = this
    have sorted': "linorder_list0.sortedP (ccw' 0) Ps"
      using Cons.prems
      by (auto elim!: linorder_list0.sortedP_Cons)
    from in_set_polychain_of_imp_sum_list[OF Cons(3)]
    obtain d
    where d: "z = (Pc + sum_list (take d (P # Ps)), Pc + sum_list (take (Suc d) (P # Ps)))" .

    from Cons(3)
    have disj: "z = (Pc, Pc + P) ∨ z ∈ set (polychain_of (Pc + P) Ps)"
      by auto

    let ?th = "λ(xi, xj). ccw xi xj Pc ∧ ccw xi xj (Pc + P)"
    have la: "list_all ?th (polychain_of (Pc + P) Ps)"
    proof (rule list_allI)
      fix x assume x: "x ∈ set (polychain_of (Pc + P) Ps)"
      from in_set_polychain_of_imp_sum_list[OF this]
      obtain e where e: "x = (Pc + P + sum_list (take e Ps), Pc + P + sum_list (take (Suc e) Ps))"
        by auto
      {
        assume "e ≥ length Ps"
        hence "?th x" by (auto simp: e)
      } moreover {
        assume "e < length Ps"
        have 0: "⋀e. e < length Ps ⟹ ccw' 0 P (Ps ! e)"
          by (rule ccw') (simp add: )
        have 2: "0 < e ⟹ ccw' 0 (P + sum_list (take e Ps)) (Ps ! e)"
          using ‹e < length Ps›
          by (auto intro!: ccw'.add1 0 ccw'.sum2 sorted' ccw'.sorted_nth_less
            simp: sum_list_sum_nth)
        have "ccw Pc (Pc + P + sum_list (take e Ps)) (Pc + P + sum_list (take (Suc e) Ps))"
          by (cases "e = 0")
            (auto simp add: ccw_translate_origin take_Suc_eq add.assoc[symmetric] 0 2
              intro!: ccw'_imp_ccw intro: cyclic)
        hence "ccw (Pc + P + sum_list (take e Ps)) (Pc + P + sum_list (take (Suc e) Ps)) Pc"
          by (rule cyclic)
        moreover
        have "0 < e ⟹ ccw 0 (Ps ! e) (- sum_list (take e Ps))"
          using ‹e < length Ps›
          by (auto simp add: take_Suc_eq add.assoc[symmetric]
              sum_list_sum_nth
            intro!: ccw'_imp_ccw ccw'.sum2 sorted' ccw'.sorted_nth_less)
        hence "ccw (Pc + P + sum_list (take e Ps)) (Pc + P + sum_list (take (Suc e) Ps)) (Pc + P)"
          by (cases "e = 0") (simp_all add: ccw_translate_origin take_Suc_eq)
        ultimately have "?th x"
          by (auto simp add: e)
      } ultimately show "?th x" by arith
    qed
    from disj have ?case
    proof
      assume z: "z ∈ set (polychain_of (Pc + P) Ps)"
      have "ccw 0 P (sum_list (take d (P # Ps)))"
      proof (cases d)
        case (Suc e) note e = this
        show ?thesis
        proof (cases e)
          case (Suc f)
          have "ccw 0 P (P + sum_list (take (Suc f) Ps))"
            using z
            by (force simp add: sum_list_sum_nth intro!: ccw'.sum intro: ccw' ccw'_imp_ccw)
          thus ?thesis
            by (simp add: e Suc)
        qed (simp add: e)
      qed simp
      hence "ccw Pc (Pc + P) (fst z)"
        by (simp add: d ccw_translate_origin)
      moreover
      from z have "ccw 0 P (P + sum_list (take d Ps))"
        by (cases d, force)
          (force simp add: sum_list_sum_nth intro!: ccw'_imp_ccw ccw'.sum intro: ccw')+
      hence "ccw Pc (Pc + P) (snd z)"
        by (simp add: d ccw_translate_origin)
      moreover
      from z Cons.prems have "list_all (λ(xi, xj). ccw xi xj (fst z) ∧ ccw xi xj (snd z))
        (polychain_of (Pc + P) Ps)"
        by (intro Cons.IH) (auto elim!: linorder_list0.sortedP_Cons)
      ultimately show ?thesis by simp
    qed (simp add: la)
  } ultimately show ?case by blast
qed simp

lemma lex_polychain_of_center:
  "d ∈ set (polychain_of x0 xs) ⟹ list_all (λx. lex x 0) xs ⟹ lex (snd d) x0"
proof (induction xs arbitrary: x0)
  case (Cons x xs) thus ?case
    by (auto simp add: lex_def lex_translate_origin dest!: Cons.IH)
qed (auto simp: lex_translate_origin)

lemma lex_polychain_of_last:
  "(c, d) ∈ set (polychain_of x0 xs) ⟹ list_all (λx. lex x 0) xs ⟹
    lex (snd (last (polychain_of x0 xs))) d"
proof (induction xs arbitrary: x0 c d)
  case (Cons x xs)
  let ?c1 = "c = x0 ∧ d = x0 + x"
  let ?c2 = "(c, d) ∈ set (polychain_of (x0 + x) xs)"
  from Cons(2) have "?c1 ∨ ?c2" by auto
  thus ?case
  proof
    assume ?c1
    with Cons.prems show ?thesis
      by (auto intro!: lex_polychain_of_center)
  next
    assume ?c2
    from Cons.IH[OF this] Cons.prems
    show ?thesis
      by auto
  qed
qed (auto simp: lex_translate_origin)

lemma distinct_fst_polychain_of:
  assumes "list_all (λx. x ≠ 0) xs"
  assumes "list_all (λx. lex x 0) xs"
  shows "distinct (map fst (polychain_of x0 xs))"
  using assms
proof (induction xs arbitrary: x0)
  case Nil
  thus ?case by simp
next
  case (Cons x xs)
  hence "⋀d. list_all (λx. lex x 0) (x # take d xs)"
    by (auto simp: list_all_iff dest!: in_set_takeD)
  from sum_list_nlex_eq_zero_iff[OF this] Cons.prems
  show ?case
    by (cases "xs = []") (auto intro!: Cons.IH elim!: in_set_polychain_of_imp_sum_list)
qed

lemma distinct_snd_polychain_of:
  assumes "list_all (λx. x ≠ 0) xs"
  assumes "list_all (λx. lex x 0) xs"
  shows "distinct (map snd (polychain_of x0 xs))"
  using assms
proof (induction xs arbitrary: x0)
  case Nil
  thus ?case by simp
next
  case (Cons x xs)
  have contra:
    "⋀d. xs ≠ [] ⟹ list_all (λx. x ≠ 0) xs ⟹ list_all ((=) 0) (take (Suc d) xs) ⟹ False"
    by (auto simp: neq_Nil_conv)
  from Cons have "⋀d. list_all (λx. lex x 0) (take (Suc d) xs)"
    by (auto simp: list_all_iff dest!: in_set_takeD)
  from sum_list_nlex_eq_zero_iff[OF this] Cons.prems contra
  show ?case
    by (cases "xs = []") (auto intro!: Cons.IH elim!: in_set_polychain_of_imp_sum_list dest!: contra)
qed


subsection ‹Orient all entries›

lift_definition nlex_pdevs::"point pdevs ⇒ point pdevs"
  is "λx n. if lex 0 (x n) then - x n else x n" by simp

lemma pdevs_apply_nlex_pdevs[simp]: "pdevs_apply (nlex_pdevs x) n =
  (if lex 0 (pdevs_apply x n) then - pdevs_apply x n else pdevs_apply x n)"
  by transfer simp

lemma nlex_pdevs_zero_pdevs[simp]: "nlex_pdevs zero_pdevs = zero_pdevs"
  by (auto intro!: pdevs_eqI)

lemma pdevs_domain_nlex_pdevs[simp]: "pdevs_domain (nlex_pdevs x) = pdevs_domain x"
  by (auto simp: pdevs_domain_def)

lemma degree_nlex_pdevs[simp]: "degree (nlex_pdevs x) = degree x"
  by (rule degree_cong) auto

lemma
  pdevs_val_nlex_pdevs:
  assumes "e ∈ UNIV → I" "uminus ` I = I"
  obtains e' where "e' ∈ UNIV → I" "pdevs_val e x = pdevs_val e' (nlex_pdevs x)"
  using assms
  by (atomize_elim, intro exI[where x="λn. if lex 0 (pdevs_apply x n) then - e n else e n"])
    (force simp: pdevs_val_pdevs_domain intro!: sum.cong)

lemma
  pdevs_val_nlex_pdevs2:
  assumes "e ∈ UNIV → I" "uminus ` I = I"
  obtains e' where "e' ∈ UNIV → I" "pdevs_val e (nlex_pdevs x) = pdevs_val e' x"
  using assms
  by (atomize_elim, intro exI[where x="λn. (if lex 0 (pdevs_apply x n) then - e n else e n)"])
    (force simp: pdevs_val_pdevs_domain intro!: sum.cong)

lemma
  pdevs_val_selsort_ccw:
  assumes "distinct xs"
  assumes "e ∈ UNIV → I"
  obtains e' where "e' ∈ UNIV → I"
    "pdevs_val e (pdevs_of_list xs) = pdevs_val e' (pdevs_of_list (ccw.selsort 0 xs))"
proof -
  have "set xs = set (ccw.selsort 0 xs)" "distinct xs" "distinct (ccw.selsort 0 xs)"
    by (simp_all add: assms)
  from this assms(2) obtain e'
  where "e' ∈ UNIV → I"
    "pdevs_val e (pdevs_of_list xs) = pdevs_val e' (pdevs_of_list (ccw.selsort 0 xs))"
    by (rule pdevs_val_permute)
  thus thesis ..
qed

lemma
  pdevs_val_selsort_ccw2:
  assumes "distinct xs"
  assumes "e ∈ UNIV → I"
  obtains e' where "e' ∈ UNIV → I"
    "pdevs_val e (pdevs_of_list (ccw.selsort 0 xs)) = pdevs_val e' (pdevs_of_list xs)"
proof -
  have "set (ccw.selsort 0 xs) = set xs" "distinct (ccw.selsort 0 xs)" "distinct xs"
    by (simp_all add: assms)
  from this assms(2) obtain e'
  where "e' ∈ UNIV → I"
    "pdevs_val e (pdevs_of_list (ccw.selsort 0 xs)) = pdevs_val e' (pdevs_of_list xs)"
    by (rule pdevs_val_permute)
  thus thesis ..
qed

lemma lex_nlex_pdevs: "lex (pdevs_apply (nlex_pdevs x) i) 0"
  by (auto simp: lex_def algebra_simps prod_eq_iff)


subsection ‹Lowest Vertex›

definition lowest_vertex::"'a::ordered_euclidean_space aform ⇒ 'a" where
  "lowest_vertex X = fst X - sum_list (map snd (list_of_pdevs (snd X)))"

lemma snd_abs: "snd (abs x) = abs (snd x)"
  by (metis abs_prod_def snd_conv)

lemma lowest_vertex:
  fixes X Y::"(real*real) aform"
  assumes "e ∈ UNIV → {-1 .. 1}"
  assumes "⋀i. snd (pdevs_apply (snd X) i) ≥ 0"
  assumes "⋀i. abs (snd (pdevs_apply (snd Y) i)) = abs (snd (pdevs_apply (snd X) i))"
  assumes "degree_aform Y = degree_aform X"
  assumes "fst Y = fst X"
  shows "snd (lowest_vertex X) ≤ snd (aform_val e Y)"
proof -
  from abs_pdevs_val_le_tdev[OF assms(1), of "snd Y"]
  have "snd ¦pdevs_val e (snd Y)¦ ≤ (∑i<degree_aform Y. ¦snd (pdevs_apply (snd X) i)¦)"
    unfolding lowest_vertex_def
    by (auto simp: aform_val_def tdev_def less_eq_prod_def snd_sum snd_abs assms)
  also have "… = (∑i<degree_aform X. snd (pdevs_apply (snd X) i))"
    by (simp add: assms)
  also have "… ≤ snd (sum_list (map snd (list_of_pdevs (snd X))))"
    by (simp add: sum_list_list_of_pdevs dense_list_of_pdevs_def sum_list_distinct_conv_sum_set
      snd_sum atLeast0LessThan)
  finally show ?thesis
    by (auto simp: aform_val_def lowest_vertex_def minus_le_iff snd_abs abs_real_def assms
      split: if_split_asm)
qed

lemma sum_list_nonposI:
  fixes xs::"'a::ordered_comm_monoid_add list"
  shows "list_all (λx. x ≤ 0) xs ⟹ sum_list xs ≤ 0"
  by (induct xs) (auto simp: intro!: add_nonpos_nonpos)

lemma center_le_lowest:
  "fst (fst X) ≤ fst (lowest_vertex (fst X, nlex_pdevs (snd X)))"
  by (auto simp: lowest_vertex_def fst_sum_list intro!: sum_list_nonposI)
    (auto simp: lex_def list_all_iff list_of_pdevs_def dest!: in_set_butlastD split: if_split_asm)

lemma lowest_vertex_eq_center_iff:
  "lowest_vertex (x0, nlex_pdevs (snd X)) = x0 ⟷ snd X = zero_pdevs"
proof
  assume "lowest_vertex (x0, nlex_pdevs (snd X)) = x0"
  then have "sum_list (map snd (list_of_pdevs (nlex_pdevs (snd X)))) = 0"
    by (simp add: lowest_vertex_def)
  moreover have "list_all (λx. Counterclockwise_2D_Arbitrary.lex x 0)
    (map snd (list_of_pdevs (nlex_pdevs (snd X))))"
    by (auto simp add: list_all_iff list_of_pdevs_def)
  ultimately have "∀x∈set (list_of_pdevs (nlex_pdevs (snd X))). snd x = 0"
    by (simp add: sum_list_nlex_eq_zero_iff list_all_iff)
  then have "pdevs_apply (snd X) i = pdevs_apply zero_pdevs i" for i
    by (simp add: list_of_pdevs_def split: if_splits)
  then show "snd X = zero_pdevs"
    by (rule pdevs_eqI)
qed (simp add: lowest_vertex_def)


subsection ‹Collinear Generators›

lemma scaleR_le_self_cancel:
  fixes c::"'a::ordered_real_vector"
  shows "a *⇩_R c ≤ c ⟷ (1 < a ∧ c ≤ 0 ∨ a < 1 ∧ 0 ≤ c ∨ a = 1)"
  using scaleR_le_0_iff[of "a - 1" c]
  by (simp add: algebra_simps)

lemma pdevs_val_coll:
  assumes coll: "list_all (coll 0 x) xs"
  assumes nlex: "list_all (λx. lex x 0) xs"
  assumes "x ≠ 0"
  assumes "f ∈ UNIV → {-1 .. 1}"
  obtains e where "e ∈ {-1 .. 1}" "pdevs_val f (pdevs_of_list xs) = e *⇩_R (sum_list xs)"
proof cases
  assume "sum_list xs = 0"
  have "pdevs_of_list xs = zero_pdevs"
    by (auto intro!: pdevs_eqI sum_list_nlex_eq_zeroI[OF nlex ‹sum_list xs = 0›]
      simp: pdevs_apply_pdevs_of_list list_all_iff dest!: nth_mem)
  hence "0 ∈ {-1 .. 1::real}" "pdevs_val f (pdevs_of_list xs) = 0 *⇩_R sum_list xs"
    by simp_all
  thus ?thesis ..
next
  assume "sum_list xs ≠ 0"
  have "sum_list (map abs xs) ≥ 0"
    by (auto intro!: sum_list_nonneg)
  hence [simp]: "¬sum_list (map abs xs) ≤ 0"
    by (metis ‹sum_list xs ≠ 0› abs_le_zero_iff antisym_conv sum_list_abs)

  have collist: "list_all (coll 0 (sum_list xs)) xs"
  proof (rule list_allI)
    fix y assume "y ∈ set xs"
    hence "coll 0 x y"
      using coll by (auto simp: list_all_iff)
    also have "coll 0 x (sum_list xs)"
      using coll by (auto simp: list_all_iff intro!: coll_sum_list)
    finally (coll_trans)
    show "coll 0 (sum_list xs) y"
      by (simp add: coll_commute ‹x ≠ 0›)
  qed

  {
    fix i assume "i < length xs"
    hence "∃r. xs ! i = r *⇩_R (sum_list xs)"
      by (metis (mono_tags) coll_scale nth_mem ‹sum_list xs ≠ 0› list_all_iff collist)
  } then obtain r where r: "⋀i. i < length xs ⟹ (xs ! i) = r i *⇩_R (sum_list xs)"
    by metis
  let ?coll = "pdevs_of_list xs"
  have "pdevs_val f (pdevs_of_list xs) =
      (∑i<degree (pdevs_of_list xs). f i *⇩_R xs ! i)"
    unfolding pdevs_val_sum
    by (simp add: pdevs_apply_pdevs_of_list less_degree_pdevs_of_list_imp_less_length)
  also have "… = (∑i<degree ?coll. (f i * r i) *⇩_R (sum_list xs))"
    by (simp add: r less_degree_pdevs_of_list_imp_less_length)
  also have "… = (∑i<degree ?coll. f i * r i) *⇩_R (sum_list xs)"
    by (simp add: algebra_simps scaleR_sum_left)
  finally have eq: "pdevs_val f ?coll = (∑i<degree ?coll. f i * r i) *⇩_R (sum_list xs)"
    (is "_ = ?e *⇩_R _")
    .

  have "abs (pdevs_val f ?coll) ≤ tdev ?coll"
    using assms(4)
    by (intro abs_pdevs_val_le_tdev) (auto simp: Pi_iff less_imp_le)
  also have "… = sum_list (map abs xs)" using assms by simp
  also note eq
  finally have less: "¦?e¦ *⇩_R abs (sum_list xs) ≤ sum_list (map abs xs)" by (simp add: abs_scaleR)
  also have "¦sum_list xs¦ = sum_list (map abs xs)"
    using coll ‹x ≠ 0› nlex
    by (rule abs_sum_list_coll)
  finally have "?e ∈ {-1 .. 1}"
    by (auto simp add: less_le scaleR_le_self_cancel)
  thus ?thesis using eq ..
qed

lemma scaleR_eq_self_cancel:
  fixes x::"'a::real_vector"
  shows "a *⇩_R x = x ⟷ a = 1 ∨ x = 0"
  using scaleR_cancel_right[of a x 1]
  by simp

lemma abs_pdevs_val_less_tdev:
  assumes "e ∈ UNIV → {-1 <..< 1}" "degree x > 0"
  shows "¦pdevs_val e x¦ < tdev x"
proof -
  have bnds: "⋀i. ¦e i¦ < 1" "⋀i. ¦e i¦ ≤ 1"
    using assms
    by (auto simp: Pi_iff abs_less_iff order.strict_implies_order)
  moreover
  let ?w = "degree x - 1"
  have witness: "¦e ?w¦ *⇩_R ¦pdevs_apply x ?w¦ < ¦pdevs_apply x ?w¦"
    using degree_least_nonzero[of x] assms bnds
    by (intro neq_le_trans) (auto simp: scaleR_eq_self_cancel Pi_iff
      intro!: scaleR_left_le_one_le neq_le_trans
      intro: abs_leI less_imp_le dest!: order.strict_implies_not_eq)
  ultimately
  show ?thesis
    using assms witness bnds
    by (auto simp: pdevs_val_sum tdev_def abs_scaleR
      intro!: le_less_trans[OF sum_abs] sum_strict_mono_ex1 scaleR_left_le_one_le)
qed

lemma pdevs_val_coll_strict:
  assumes coll: "list_all (coll 0 x) xs"
  assumes nlex: "list_all (λx. lex x 0) xs"
  assumes "x ≠ 0"
  assumes "f ∈ UNIV → {-1 <..< 1}"
  obtains e where "e ∈ {-1 <..< 1}" "pdevs_val f (pdevs_of_list xs) = e *⇩_R (sum_list xs)"
proof cases
  assume "sum_list xs = 0"
  have "pdevs_of_list xs = zero_pdevs"
    by (auto intro!: pdevs_eqI sum_list_nlex_eq_zeroI[OF nlex ‹sum_list xs = 0›]
      simp: pdevs_apply_pdevs_of_list list_all_iff dest!: nth_mem)
  hence "0 ∈ {-1 <..< 1::real}" "pdevs_val f (pdevs_of_list xs) = 0 *⇩_R sum_list xs"
    by simp_all
  thus ?thesis ..
next
  assume "sum_list xs ≠ 0"
  have "sum_list (map abs xs) ≥ 0"
    by (auto intro!: sum_list_nonneg)
  hence [simp]: "¬sum_list (map abs xs) ≤ 0"
    by (metis ‹sum_list xs ≠ 0› abs_le_zero_iff antisym_conv sum_list_abs)

  have "∃x ∈ set xs. x ≠ 0"
  proof (rule ccontr)
    assume "¬ (∃x∈set xs. x ≠ 0)"
    hence "⋀x. x ∈ set xs ⟹ x = 0" by auto
    hence "sum_list xs = 0"
      by (auto simp: sum_list_eq_0_iff_nonpos list_all_iff less_eq_prod_def prod_eq_iff fst_sum_list
        snd_sum_list)
    thus False using ‹sum_list xs ≠ 0› by simp
  qed
  then obtain i where i: "i < length xs" "xs ! i ≠ 0"
    by (metis in_set_conv_nth)
  hence "i < degree (pdevs_of_list xs)"
    by (auto intro!: degree_gt simp: pdevs_apply_pdevs_of_list)
  hence deg_pos: "0 < degree (pdevs_of_list xs)" by simp

  have collist: "list_all (coll 0 (sum_list xs)) xs"
  proof (rule list_allI)
    fix y assume "y ∈ set xs"
    hence "coll 0 x y"
      using coll by (auto simp: list_all_iff)
    also have "coll 0 x (sum_list xs)"
      using coll by (auto simp: list_all_iff intro!: coll_sum_list)
    finally (coll_trans)
    show "coll 0 (sum_list xs) y"
      by (simp add: coll_commute ‹x ≠ 0›)
  qed

  {
    fix i assume "i < length xs"
    hence "∃r. xs ! i = r *⇩_R (sum_list xs)"
      by (metis (mono_tags, lifting) ‹sum_list xs ≠ 0› coll_scale collist list_all_iff nth_mem)
  } then obtain r where r: "⋀i. i < length xs ⟹ (xs ! i) = r i *⇩_R (sum_list xs)"
    by metis
  let ?coll = "pdevs_of_list xs"
  have "pdevs_val f (pdevs_of_list xs) =
      (∑i<degree (pdevs_of_list xs). f i *⇩_R xs ! i)"
    unfolding pdevs_val_sum
    by (simp add: less_degree_pdevs_of_list_imp_less_length pdevs_apply_pdevs_of_list)
  also have "… = (∑i<degree ?coll. (f i * r i) *⇩_R (sum_list xs))"
    by (simp add: r less_degree_pdevs_of_list_imp_less_length)
  also have "… = (∑i<degree ?coll. f i * r i) *⇩_R (sum_list xs)"
    by (simp add: algebra_simps scaleR_sum_left)
  finally have eq: "pdevs_val f ?coll = (∑i<degree ?coll. f i * r i) *⇩_R (sum_list xs)"
    (is "_ = ?e *⇩_R _")
    .

  have "abs (pdevs_val f ?coll) < tdev ?coll"
    using assms(4)
    by (intro abs_pdevs_val_less_tdev) (auto simp: Pi_iff less_imp_le deg_pos)
  also have "… = sum_list (map abs xs)" using assms by simp
  also note eq
  finally have less: "¦?e¦ *⇩_R abs (sum_list xs) < sum_list (map abs xs)" by (simp add: abs_scaleR)
  also have "¦sum_list xs¦ = sum_list (map abs xs)"
    using coll ‹x ≠ 0› nlex
    by (rule abs_sum_list_coll)
  finally have "?e ∈ {-1 <..< 1}"
    by (auto simp add: less_le scaleR_le_self_cancel)
  thus ?thesis using eq ..
qed


subsection ‹Independent Generators›

fun independent_pdevs::"point list ⇒ point list"
  where
  "independent_pdevs [] = []"
| "independent_pdevs (x#xs) =
    (let
      (cs, is) = List.partition (coll 0 x) xs;
      s = x + sum_list cs
    in (if s = 0 then [] else [s]) @ independent_pdevs is)"

lemma in_set_independent_pdevsE:
  assumes "y ∈ set (independent_pdevs xs)"
  obtains x where "x∈set xs" "coll 0 x y"
proof atomize_elim
  show "∃x. x ∈ set xs ∧ coll 0 x y"
    using assms
  proof (induct xs rule: independent_pdevs.induct)
    case 1 thus ?case by simp
  next
    case (2 z zs)
    let ?c1 = "y = z + sum_list (filter (coll 0 z) zs)"
    let ?c2 = "y ∈ set (independent_pdevs (filter (Not ∘ coll 0 z) zs))"
    from 2
    have "?c1 ∨ ?c2"
      by (auto simp: Let_def split: if_split_asm)
    thus ?case
    proof
      assume ?c2
      hence "y ∈ set (independent_pdevs (snd (partition (coll 0 z) zs)))"
        by simp
      from 2(1)[OF refl prod.collapse refl this]
      show ?case
        by auto
    next
      assume y: ?c1
      show ?case
        unfolding y
        by (rule exI[where x="z"]) (auto intro!: coll_add coll_sum_list )
    qed
  qed
qed

lemma in_set_independent_pdevs_nonzero: "x ∈ set (independent_pdevs xs) ⟹ x ≠ 0"
proof (induct xs rule: independent_pdevs.induct)
  case (2 y ys)
  from 2(1)[OF refl prod.collapse refl] 2(2)
  show ?case
    by (auto simp: Let_def split: if_split_asm)
qed simp

lemma independent_pdevs_pairwise_non_coll:
  assumes "x ∈ set (independent_pdevs xs)"
  assumes "y ∈ set (independent_pdevs xs)"
  assumes "⋀x. x ∈ set xs ⟹ x ≠ 0"
  assumes "x ≠ y"
  shows "¬ coll 0 x y"
using assms
proof (induct xs rule: independent_pdevs.induct)
  case 1 thus ?case by simp
next
  case (2 z zs)
  from 2 have "z ≠ 0" by simp
  from 2(2) have "x ≠ 0" by (rule in_set_independent_pdevs_nonzero)
  from 2(3) have "y ≠ 0" by (rule in_set_independent_pdevs_nonzero)
  let ?c = "filter (coll 0 z) zs"
  let ?nc = "filter (Not ∘ coll 0 z) zs"
  {
    assume "x ∈ set (independent_pdevs ?nc)" "y ∈ set (independent_pdevs ?nc)"
    hence "¬coll 0 x y"
      by (intro 2(1)[OF refl prod.collapse refl _ _ 2(4) 2(5)]) auto
  } note IH = this
  {
    fix x assume "x ≠ 0" "z + sum_list ?c ≠ 0"
      "coll 0 x (z + sum_list ?c)"
    hence "x ∉ set (independent_pdevs ?nc)"
      using sum_list_filter_coll_ex_scale[OF ‹z ≠ 0›, of "z#zs"]
      by (auto elim!: in_set_independent_pdevsE  simp: coll_commute)
        (metis (no_types) ‹x ≠ 0› coll_scale coll_scaleR)
  } note nc = this
  from 2(2,3,4,5) nc[OF ‹x ≠ 0›] nc[OF ‹y ≠ 0›]
  show ?case
    by (auto simp: Let_def IH coll_commute split: if_split_asm)
qed

lemma distinct_independent_pdevs[simp]:
  shows "distinct (independent_pdevs xs)"
proof (induct xs rule: independent_pdevs.induct)
  case 1 thus ?case by simp
next
  case (2 x xs)
  let ?is = "independent_pdevs (filter (Not ∘ coll 0 x) xs)"
  have "distinct ?is"
    by (rule 2) (auto intro!: 2)
  thus ?case
  proof (clarsimp simp add: Let_def)
    let ?s = "x + sum_list (filter (coll 0 x) xs)"
    assume s: "?s ≠ 0" "?s ∈ set ?is"
    from in_set_independent_pdevsE[OF s(2)]
    obtain y where y:
      "y ∈ set (filter (Not ∘ coll 0 x) xs)"
      "coll 0 y (x + sum_list (filter (coll 0 x) xs))"
      by auto
    {
      assume "y = 0 ∨ x = 0 ∨ sum_list (filter (coll 0 x) xs) = 0"
      hence False using s y by (auto simp: coll_commute)
    } moreover {
      assume "y ≠ 0" "x ≠ 0" "sum_list (filter (coll 0 x) xs) ≠ 0"
        "sum_list (filter (coll 0 x) xs) + x ≠ 0"
      have *: "coll 0 (sum_list (filter (coll 0 x) xs)) x"
        by (auto intro!: coll_sum_list simp: coll_commute)
      have "coll 0 y (sum_list (filter (coll 0 x) xs) + x)"
        using s y by (simp add: add.commute)
      hence "coll 0 y x" using *
        by (rule coll_add_trans) fact+
      hence False using s y by (simp add: coll_commute)
    } ultimately show False using s y by (auto simp: add.commute)
  qed
qed

lemma in_set_independent_pdevs_invariant_nlex:
  "x ∈ set (independent_pdevs xs) ⟹ (⋀x. x ∈ set xs ⟹ lex x 0) ⟹
  (⋀x. x ∈ set xs ⟹ x ≠ 0) ⟹ Counterclockwise_2D_Arbitrary.lex x 0"
proof (induction xs arbitrary: x rule: independent_pdevs.induct )
  case 1 thus ?case by simp
next
  case (2 y ys)
  from 2 have "y ≠ 0" by auto
  from 2(2)
  have "x ∈ set (independent_pdevs (filter (Not ∘ coll 0 y) ys)) ∨
    x = y + sum_list (filter (coll 0 y) ys)"
    by (auto simp: Let_def split: if_split_asm)
  thus ?case
  proof
    assume "x ∈ set (independent_pdevs (filter (Not ∘ coll 0 y) ys))"
    from 2(1)[OF refl prod.collapse refl, simplified, OF this 2(3,4)]
    show ?case by simp
  next
    assume "x = y + sum_list (filter (coll 0 y) ys)"
    also have "lex … 0"
      by (force intro: nlex_add nlex_sum simp: sum_list_sum_nth
        dest: nth_mem intro: 2(3))
    finally show ?case .
  qed
qed

lemma
  pdevs_val_independent_pdevs2:
  assumes "e ∈ UNIV → I"
  shows "∃e'. e' ∈ UNIV → I ∧
    pdevs_val e (pdevs_of_list (independent_pdevs xs)) = pdevs_val e' (pdevs_of_list xs)"
  using assms
proof (induct xs arbitrary: e rule: independent_pdevs.induct)
  case 1 thus ?case by force
next
  case (2 x xs)
  let ?coll = "(filter (coll 0 x) (x#xs))"
  let ?ncoll = "(filter (Not o coll 0 x) (x#xs))"
  let ?e0 = "if sum_list ?coll = 0 then e else e ∘ (+) (Suc 0)"
  have "pdevs_val e (pdevs_of_list (independent_pdevs (x#xs))) =
    e 0 *⇩_R (sum_list ?coll) + pdevs_val ?e0 (pdevs_of_list (independent_pdevs ?ncoll))"
    (is "_ = ?vc + ?vnc")
    by (simp add: Let_def)
  also
  have e_split: "(λ_. e 0) ∈ UNIV → I" "?e0 ∈ UNIV → I"
    using 2(2) by auto
  from 2(1)[OF refl prod.collapse refl e_split(2)]
  obtain e' where e': "e' ∈ UNIV → I" and "?vnc = pdevs_val e' (pdevs_of_list ?ncoll)"
    by (auto simp add: o_def)
  note this(2)
  also
  have "?vc = pdevs_val (λ_. e 0) (pdevs_of_list ?coll)"
    by (simp add: pdevs_val_const_pdevs_of_list)
  also
  from pdevs_val_pdevs_of_list_append[OF e_split(1) e'] obtain e'' where
    e'': "e'' ∈ UNIV → I"
    and "pdevs_val (λ_. e 0) (pdevs_of_list ?coll) + pdevs_val e' (pdevs_of_list ?ncoll) =
      pdevs_val e'' (pdevs_of_list (?coll @ ?ncoll))"
    by metis
  note this(2)
  also
  from pdevs_val_perm[OF partition_permI e'', of "coll 0 x" "x#xs"]
  obtain e''' where e''': "e''' ∈ UNIV → I"
    and "… = pdevs_val e''' (pdevs_of_list (x # xs))"
    by metis
  note this(2)
  finally show ?case using e''' by auto
qed

lemma list_all_filter: "list_all p (filter p xs)"
  by (induct xs) auto

lemma pdevs_val_independent_pdevs:
  assumes "list_all (λx. lex x 0) xs"
  assumes "list_all (λx. x ≠ 0) xs"
  assumes "e ∈ UNIV → {-1 .. 1}"
  shows "∃e'. e' ∈ UNIV → {-1 .. 1} ∧ pdevs_val e (pdevs_of_list xs) =
    pdevs_val e' (pdevs_of_list (independent_pdevs xs))"
  using assms(1,2,3)
proof (induct xs arbitrary: e rule: independent_pdevs.induct)
  case 1 thus ?case by force
next
  case (2 x xs)

  let ?coll = "(filter (coll 0 x) (x#xs))"
  let ?ncoll = "(filter (Not o coll 0 x) xs)"

  from 2 have "x ≠ 0" by simp

  from pdevs_val_partition[OF 2(4), of "x#xs" "coll 0 x"]
  obtain f g where part: "pdevs_val e (pdevs_of_list (x # xs)) =
      pdevs_val f (pdevs_of_list ?coll) +
      pdevs_val g (pdevs_of_list (filter (Not o coll 0 x) (x#xs)))"
    and f: "f ∈ UNIV → {-1 .. 1}" and g: "g ∈ UNIV → {-1 .. 1}"
    by blast
  note part
  also

  have "list_all (λx. lex x 0) (filter (coll 0 x) (x#xs))"
    using 2(2) by (auto simp: inner_prod_def list_all_iff)
  from pdevs_val_coll[OF list_all_filter this ‹x ≠ 0› f]
  obtain f' where "pdevs_val f (pdevs_of_list ?coll) = f' *⇩_R sum_list (filter (coll 0 x) (x#xs))"
    and f': "f' ∈ {-1 .. 1}"
    by blast
  note this(1)
  also

  have "filter (Not o coll 0 x) (x#xs) = ?ncoll"
    by simp
  also

  from 2(2) have "list_all (λx. lex x 0) ?ncoll" "list_all (λx. x ≠ 0) ?ncoll"
    by (auto simp: list_all_iff)
  from 2(1)[OF refl partition_filter_conv[symmetric] refl this g]
  obtain g'
  where "pdevs_val g (pdevs_of_list ?ncoll) =
      pdevs_val g' (pdevs_of_list (independent_pdevs ?ncoll))"
    and g': "g' ∈ UNIV → {-1 .. 1}"
    by metis
  note this(1)
  also

  define h where "h = (if sum_list ?coll ≠ 0 then rec_nat f' (λi _. g' i) else g')"
  have "f' *⇩_R sum_list ?coll + pdevs_val g' (pdevs_of_list (independent_pdevs ?ncoll))
      = pdevs_val h (pdevs_of_list (independent_pdevs (x#xs)))"
    by (simp add: h_def o_def Let_def)

  finally
  have "pdevs_val e (pdevs_of_list (x # xs)) =
      pdevs_val h (pdevs_of_list (independent_pdevs (x # xs)))" .

  moreover have "h ∈ UNIV → {-1 .. 1}"
  proof
    fix i show "h i ∈ {-1 .. 1}"
      using f' g'
      by (cases i) (auto simp: h_def)
  qed

  ultimately show ?case by blast
qed

lemma
  pdevs_val_independent_pdevs_strict:
  assumes "list_all (λx. lex x 0) xs"
  assumes "list_all (λx. x ≠ 0) xs"
  assumes "e ∈ UNIV → {-1 <..< 1}"
  shows "∃e'. e' ∈ UNIV → {-1 <..< 1} ∧ pdevs_val e (pdevs_of_list xs) =
    pdevs_val e' (pdevs_of_list (independent_pdevs xs))"
  using assms(1,2,3)
proof (induct xs arbitrary: e rule: independent_pdevs.induct)
  case 1 thus ?case by force
next
  case (2 x xs)

  let ?coll = "(filter (coll 0 x) (x#xs))"
  let ?ncoll = "(filter (Not o coll 0 x) xs)"

  from 2 have "x ≠ 0" by simp

  from pdevs_val_partition[OF 2(4), of "x#xs" "coll 0 x"]
  obtain f g
  where part: "pdevs_val e (pdevs_of_list (x # xs)) =
      pdevs_val f (pdevs_of_list ?coll) +
      pdevs_val g (pdevs_of_list (filter (Not o coll 0 x) (x#xs)))"
    and f: "f ∈ UNIV → {-1 <..< 1}" and g: "g ∈ UNIV → {-1 <..< 1}"
    by blast
  note part
  also

  have "list_all (λx. lex x 0) (filter (coll 0 x) (x#xs))"
    using 2(2) by (auto simp: inner_prod_def list_all_iff)
  from pdevs_val_coll_strict[OF list_all_filter this ‹x ≠ 0› f]
  obtain f' where "pdevs_val f (pdevs_of_list ?coll) = f' *⇩_R sum_list (filter (coll 0 x) (x#xs))"
    and f': "f' ∈ {-1 <..< 1}"
    by blast
  note this(1)
  also

  have "filter (Not o coll 0 x) (x#xs) = ?ncoll"
    by simp
  also

  from 2(2) have "list_all (λx. lex x 0) ?ncoll" "list_all (λx. x ≠ 0) ?ncoll"
    by (auto simp: list_all_iff)
  from 2(1)[OF refl partition_filter_conv[symmetric] refl this g]
  obtain g'
  where "pdevs_val g (pdevs_of_list ?ncoll) =
      pdevs_val g' (pdevs_of_list (independent_pdevs ?ncoll))"
    and g': "g' ∈ UNIV → {-1 <..< 1}"
    by metis
  note this(1)
  also

  define h where "h = (if sum_list ?coll ≠ 0 then rec_nat f' (λi _. g' i) else g')"
  have "f' *⇩_R sum_list ?coll + pdevs_val g' (pdevs_of_list (independent_pdevs ?ncoll))
      = pdevs_val h (pdevs_of_list (independent_pdevs (x#xs)))"
    by (simp add: h_def o_def Let_def)

  finally
  have "pdevs_val e (pdevs_of_list (x # xs)) =
      pdevs_val h (pdevs_of_list (independent_pdevs (x # xs)))" .

  moreover have "h ∈ UNIV → {-1 <..< 1}"
  proof
    fix i show "h i ∈ {-1 <..< 1}"
      using f' g'
      by (cases i) (auto simp: h_def)
  qed

  ultimately show ?case by blast
qed

lemma sum_list_independent_pdevs: "sum_list (independent_pdevs xs) = sum_list xs"
proof (induct xs rule: independent_pdevs.induct)
  case (2 y ys)
  from 2[OF refl prod.collapse refl]
  show ?case
    using sum_list_partition[of "coll 0 y" ys, symmetric]
    by (auto simp: Let_def)
qed simp

lemma independent_pdevs_eq_Nil_iff:
  "list_all (λx. lex x 0) xs ⟹ list_all (λx. x ≠ 0) xs ⟹ independent_pdevs xs = [] ⟷ xs = []"
proof (induct xs)
  case Nil thus ?case by simp
next
  case (Cons x xs)
  from Cons(2) have "list_all (λx. lex x 0) (x # filter (coll 0 x) xs)"
    by (auto simp: list_all_iff)
  from sum_list_nlex_eq_zero_iff[OF this] Cons(3)
  show ?case
    by (auto simp: list_all_iff)
qed


subsection ‹Independent Oriented Generators›

definition "inl p = independent_pdevs (map snd (list_of_pdevs (nlex_pdevs p)))"

lemma distinct_inl[simp]: "distinct (inl (snd X))"
  by (auto simp: inl_def)

lemma in_set_inl_nonzero: "x ∈ set (inl xs) ⟹ x ≠ 0"
  by (auto simp: inl_def in_set_independent_pdevs_nonzero)

lemma
  inl_ncoll: "y ∈ set (inl (snd X)) ⟹ z ∈ set (inl (snd X)) ⟹ y ≠ z ⟹ ¬coll 0 y z"
  unfolding inl_def
  by (rule independent_pdevs_pairwise_non_coll, assumption+)
    (auto simp: inl_def list_of_pdevs_nonzero)

lemma in_set_inl_lex: "x ∈ set (inl xs) ⟹ lex x 0"
  by (auto simp: inl_def list_of_pdevs_def dest!: in_set_independent_pdevs_invariant_nlex
    split: if_split_asm)

interpretation ccw0: linorder_list "ccw 0" "set (inl (snd X))"
proof unfold_locales
  fix a b c
  show "a ≠ b ⟹ ccw 0 a b ∨ ccw 0 b a"
    by (metis UNIV_I ccw_self(1) nondegenerate)
  assume a: "a ∈ set (inl (snd X))"
  show "ccw 0 a a"
    by simp
  assume b: "b ∈ set (inl (snd X))"
  show "ccw 0 a b ⟹ ccw 0 b a ⟹ a = b"
    by (metis ccw_self(1) in_set_inl_nonzero mem_Collect_eq not_ccw_eq a b)
  assume c: "c ∈ set (inl (snd X))"
  assume distinct: "a ≠ b" "b ≠ c" "a ≠ c"
  assume ab: "ccw 0 a b" and bc: "ccw 0 b c"
  show "ccw 0 a c"
    using a b c ab bc
  proof (cases "a = (0, 1)" "b = (0, 1)" "c = (0, 1)"
      rule: case_split[case_product case_split[case_product case_split]])
    assume nu: "a ≠ (0, 1)" "b ≠ (0, 1)" "c ≠ (0, 1)"
    have "distinct5 a b c (0, 1) 0" "in5 UNIV a b c (0, 1) 0"
      using a b c distinct nu by (simp_all add: in_set_inl_nonzero)
    moreover have "ccw 0 (0, 1) a" "ccw 0 (0, 1) b" "ccw 0 (0, 1) c"
      by (auto intro!: nlex_ccw_left in_set_inl_lex a b c)
    ultimately show ?thesis using ab bc
      by (rule ccw.transitive[where S=UNIV and s="(0, 1)"])
  next
    assume "a ≠ (0, 1)" "b = (0, 1)" "c ≠ (0, 1)"
    thus ?thesis
      using ccw_switch23 in_set_inl_lex inl_ncoll nlex_ccw_left a b ab
      by blast
  next
    assume "a ≠ (0, 1)" "b ≠ (0, 1)" "c = (0, 1)"
    thus ?thesis
      using ccw_switch23 in_set_inl_lex inl_ncoll nlex_ccw_left b c bc
      by blast
  qed (auto simp add: nlex_ccw_left in_set_inl_lex)
qed

lemma sorted_inl: "ccw.sortedP 0 (ccw.selsort 0 (inl (snd X)))"
  by (rule ccw0.sortedP_selsort) auto

lemma sorted_scaled_inl: "ccw.sortedP 0 (map ((*⇩_R) 2) (ccw.selsort 0 (inl (snd X))))"
  using sorted_inl
  by (rule ccw_sorted_scaleR) simp

lemma distinct_selsort_inl: "distinct (ccw.selsort 0 (inl (snd X)))"
  by simp

lemma distinct_map_scaleRI:
  fixes xs::"'a::real_vector list"
  shows "distinct xs ⟹ c ≠ 0 ⟹ distinct (map ((*⇩_R) c) xs)"
  by (induct xs) auto

lemma distinct_scaled_inl: "distinct (map ((*⇩_R) 2) (ccw.selsort 0 (inl (snd X))))"
  using distinct_selsort_inl
  by (rule distinct_map_scaleRI) simp

lemma ccw'_sortedP_scaled_inl:
  "ccw'.sortedP 0 (map ((*⇩_R) 2) (ccw.selsort 0 (inl (snd X))))"
  using ccw_sorted_implies_ccw'_sortedP
  by (rule ccw'_sorted_scaleR) (auto simp: sorted_inl inl_ncoll)

lemma pdevs_val_pdevs_of_list_inl2E:
  assumes "e ∈ UNIV → {-1 .. 1}"
  obtains e' where "pdevs_val e X = pdevs_val e' (pdevs_of_list (inl X))" "e' ∈ UNIV → {-1 .. 1}"
proof -
  let ?l = "map snd (list_of_pdevs (nlex_pdevs X))"
  have l: "list_all (λx. Counterclockwise_2D_Arbitrary.lex x 0) ?l"
    "list_all (λx. x ≠ 0) (map snd (list_of_pdevs (nlex_pdevs X)))"
    by (auto simp: list_all_iff list_of_pdevs_def)

  from pdevs_val_nlex_pdevs[OF assms(1)]
  obtain e' where "e' ∈ UNIV → {-1 .. 1}" "pdevs_val e X = pdevs_val e' (nlex_pdevs X)"
    by auto
  note this(2)
  also from pdevs_val_of_list_of_pdevs2[OF ‹e' ∈ _›]
  obtain e'' where "e'' ∈ UNIV → {-1 .. 1}" "… = pdevs_val e'' (pdevs_of_list ?l)"
    by metis
  note this(2)
  also from pdevs_val_independent_pdevs[OF l ‹e'' ∈ _›]
  obtain e'''
  where "e''' ∈ UNIV → {-1 .. 1}"
    and "… = pdevs_val e''' (pdevs_of_list (independent_pdevs ?l))"
    by metis
  note this(2)
  also have "… = pdevs_val e''' (pdevs_of_list (inl X))"
    by (simp add: inl_def)
  finally have "pdevs_val e X = pdevs_val e''' (pdevs_of_list (inl X))" .
  thus thesis using ‹e''' ∈ _› ..
qed

lemma pdevs_val_pdevs_of_list_inlE:
  assumes "e ∈ UNIV → I" "uminus ` I = I" "0 ∈ I"
  obtains e' where "pdevs_val e (pdevs_of_list (inl X)) = pdevs_val e' X" "e' ∈ UNIV → I"
proof -
  let ?l = "map snd (list_of_pdevs (nlex_pdevs X))"
  have "pdevs_val e (pdevs_of_list (inl X)) = pdevs_val e (pdevs_of_list (independent_pdevs ?l))"
    by (simp add: inl_def)
  also
  from pdevs_val_independent_pdevs2[OF ‹e ∈ _›]
  obtain e'
  where "pdevs_val e (pdevs_of_list (independent_pdevs ?l)) = pdevs_val e' (pdevs_of_list ?l)"
    and "e' ∈ UNIV → I"
    by auto
  note this(1)
  also
  from pdevs_val_of_list_of_pdevs[OF ‹e' ∈ _› ‹0 ∈ I›, of "nlex_pdevs X"]
  obtain e'' where "pdevs_val e' (pdevs_of_list ?l) = pdevs_val e'' (nlex_pdevs X)"
    and "e'' ∈ UNIV → I"
    by metis
  note this(1)
  also
  from pdevs_val_nlex_pdevs2[OF ‹e'' ∈ _› ‹_ = I›]
  obtain e''' where "pdevs_val e'' (nlex_pdevs X) = pdevs_val e''' X" "e''' ∈ UNIV → I"
    by metis
  note this(1)
  finally have "pdevs_val e (pdevs_of_list (inl X)) = pdevs_val e''' X" .
  thus ?thesis using ‹e''' ∈ UNIV → I› ..
qed

lemma sum_list_nlex_eq_sum_list_inl:
  "sum_list (map snd (list_of_pdevs (nlex_pdevs X))) = sum_list (inl X)"
  by (auto simp: inl_def sum_list_list_of_pdevs sum_list_independent_pdevs)

lemma Affine_inl: "Affine (fst X, pdevs_of_list (inl (snd X))) = Affine X"
  by (auto simp: Affine_def valuate_def aform_val_def
    elim: pdevs_val_pdevs_of_list_inlE[of _ _ "snd X"] pdevs_val_pdevs_of_list_inl2E[of _ "snd X"])


subsection ‹Half Segments›

definition half_segments_of_aform::"point aform ⇒ (point*point) list"
  where "half_segments_of_aform X =
    (let
      x0 = lowest_vertex (fst X, nlex_pdevs (snd X))
    in
      polychain_of x0 (map ((*⇩_R) 2) (ccw.selsort 0 (inl (snd X)))))"

lemma subsequent_half_segments:
  fixes X
  assumes "Suc i < length (half_segments_of_aform X)"
  shows "snd (half_segments_of_aform X ! i) = fst (half_segments_of_aform X ! Suc i)"
  using assms
  by (cases i) (auto simp: half_segments_of_aform_def Let_def polychain_of_subsequent_eq)

lemma polychain_half_segments_of_aform: "polychain (half_segments_of_aform X)"
  by (auto simp: subsequent_half_segments intro!: polychainI)

lemma fst_half_segments:
  "half_segments_of_aform X ≠ [] ⟹
    fst (half_segments_of_aform X ! 0) = lowest_vertex (fst X, nlex_pdevs (snd X))"
  by (auto simp: half_segments_of_aform_def Let_def o_def split_beta')

lemma nlex_half_segments_of_aform: "(a, b) ∈ set (half_segments_of_aform X) ⟹ lex b a"
  by (auto simp: half_segments_of_aform_def prod_eq_iff lex_def
    dest!: in_set_polychain_ofD in_set_inl_lex)

lemma ccw_half_segments_of_aform_all:
  assumes cd: "(c, d) ∈ set (half_segments_of_aform X)"
  shows "list_all (λ(xi, xj). ccw xi xj c ∧ ccw xi xj d) (half_segments_of_aform X)"
proof -
  have
    "list_all (λ(xi, xj). ccw xi xj (fst (c, d)) ∧ ccw xi xj (snd (c, d)))
      (polychain_of (lowest_vertex (fst X, nlex_pdevs (snd X)))
        ((map ((*⇩_R) 2) (linorder_list0.selsort (ccw 0) (inl (snd X))))))"
    using ccw'_sortedP_scaled_inl cd[unfolded half_segments_of_aform_def Let_def]
    by (rule polychain_of_ccw_conjunction)
  thus ?thesis
    unfolding half_segments_of_aform_def[unfolded Let_def, symmetric] fst_conv snd_conv .
qed

lemma ccw_half_segments_of_aform:
  assumes ij: "(xi, xj) ∈ set (half_segments_of_aform X)"
  assumes c: "(c, d) ∈ set (half_segments_of_aform X)"
  shows "ccw xi xj c" "ccw xi xj d"
  using ccw_half_segments_of_aform_all[OF c] ij
  by (auto simp add: list_all_iff)

lemma half_segments_of_aform1:
  assumes ch: "x ∈ convex hull set (map fst (half_segments_of_aform X))"
  assumes ab: "(a, b) ∈ set (half_segments_of_aform X)"
  shows "ccw a b x"
  using finite_set _ ch
proof (rule ccw.convex_hull)
  fix c assume "c ∈ set (map fst (half_segments_of_aform X))"
  then obtain d where "(c, d) ∈ set (half_segments_of_aform X)" by auto
  with ab show "ccw a b c"
    by (rule ccw_half_segments_of_aform(1))
qed (insert ab, simp add: nlex_half_segments_of_aform)

lemma half_segments_of_aform2:
  assumes ch: "x ∈ convex hull set (map snd (half_segments_of_aform X))"
  assumes ab: "(a, b) ∈ set (half_segments_of_aform X)"
  shows "ccw a b x"
  using finite_set _ ch
proof (rule ccw.convex_hull)
  fix d assume "d ∈ set (map snd (half_segments_of_aform X))"
  then obtain c where "(c, d) ∈ set (half_segments_of_aform X)" by auto
  with ab show "ccw a b d"
    by (rule ccw_half_segments_of_aform(2))
qed (insert ab, simp add: nlex_half_segments_of_aform)

lemma
  in_set_half_segments_of_aform_aform_valE:
  assumes "(x2, y2) ∈ set (half_segments_of_aform X)"
  obtains e where "y2 = aform_val e X" "e ∈ UNIV → {-1 .. 1}"
proof -
  from assms obtain d where
    "y2 = lowest_vertex (fst X, nlex_pdevs (snd X)) +
      sum_list (take (Suc d) (map ((*⇩_R) 2) (ccw.selsort 0 (inl (snd X)))))"
    by (auto simp: half_segments_of_aform_def elim!: in_set_polychain_of_imp_sum_list)
  also have "lowest_vertex (fst X, nlex_pdevs (snd X)) =
      fst X - sum_list (map snd (list_of_pdevs (nlex_pdevs (snd X))))"
    by (simp add: lowest_vertex_def)
  also have "sum_list (map snd (list_of_pdevs (nlex_pdevs (snd X)))) =
      pdevs_val (λ_. 1) (nlex_pdevs (snd X))"
    by (auto simp: pdevs_val_sum_list)
  also

  have "sum_list (take (Suc d) (map ((*⇩_R) 2) (ccw.selsort 0 (inl (snd X))))) =
      pdevs_val (λi. if i ≤ d then 2 else 0) (pdevs_of_list (ccw.selsort 0 (inl (snd X))))"
    (is "_ = pdevs_val ?e _")
    by (subst sum_list_take_pdevs_val_eq)
      (auto simp: pdevs_val_sum if_distrib pdevs_apply_pdevs_of_list
        degree_pdevs_of_list_scaleR intro!: sum.cong )
  also
  obtain e'' where "… = pdevs_val e'' (pdevs_of_list (inl (snd X)))" "e'' ∈ UNIV → {0..2}"
    by (auto intro: pdevs_val_selsort_ccw2[of "inl (snd X)" ?e "{0 .. 2}"])
  note this(1)
  also note inl_def
  also
  let ?l = "map snd (list_of_pdevs (nlex_pdevs (snd X)))"
  from pdevs_val_independent_pdevs2[OF ‹e'' ∈ _›]
  obtain e'''
  where "pdevs_val e'' (pdevs_of_list (independent_pdevs ?l)) = pdevs_val e''' (pdevs_of_list ?l)"
    and "e''' ∈ UNIV → {0..2}"
    by auto
  note this(1)
  also
  have "0 ∈ {0 .. 2::real}" by simp
  from pdevs_val_of_list_of_pdevs[OF ‹e''' ∈ _› this, of "nlex_pdevs (snd X)"]
  obtain e'''' where "pdevs_val e''' (pdevs_of_list ?l) = pdevs_val e'''' (nlex_pdevs (snd X))"
    and "e'''' ∈ UNIV → {0 .. 2}"
    by metis
  note this(1)
  finally have
    "y2 = fst X + (pdevs_val e'''' (nlex_pdevs (snd X)) - pdevs_val (λ_. 1) (nlex_pdevs (snd X)))"
    by simp
  also have "pdevs_val e'''' (nlex_pdevs (snd X)) - pdevs_val (λ_. 1) (nlex_pdevs (snd X)) =
      pdevs_val (λi. e'''' i - 1) (nlex_pdevs (snd X))"
    by (simp add: pdevs_val_minus)
  also
  have "(λi. e'''' i - 1) ∈ UNIV → {-1 .. 1}" using ‹e'''' ∈ _› by auto
  from pdevs_val_nlex_pdevs2[OF this]
  obtain f where "f ∈ UNIV →  {-1 .. 1}"
    and "pdevs_val (λi. e'''' i - 1) (nlex_pdevs (snd X)) = pdevs_val f (snd X)"
    by auto
  note this(2)
  finally have "y2 = aform_val f X" by (simp add: aform_val_def)
  thus ?thesis using ‹f ∈ _› ..
qed

lemma fst_hd_half_segments_of_aform:
  assumes "half_segments_of_aform X ≠ []"
  shows "fst (hd (half_segments_of_aform X)) = lowest_vertex (fst X, (nlex_pdevs (snd X)))"
  using assms
  by (auto simp: half_segments_of_aform_def Let_def fst_hd_polychain_of)

lemma
  "linorder_list0.sortedP (ccw' (lowest_vertex (fst X, nlex_pdevs (snd X))))
    (map snd (half_segments_of_aform X))"
  (is "linorder_list0.sortedP (ccw' ?x0) ?ms")
  unfolding half_segments_of_aform_def Let_def
  by (rule ccw'_sortedP_polychain_of_snd) (rule ccw'_sortedP_scaled_inl)

lemma rev_zip: "length xs = length ys ⟹ rev (zip xs ys) = zip (rev xs) (rev ys)"
  by (induct xs ys rule: list_induct2) auto

lemma zip_upt_self_aux: "zip [0..<length xs] xs = map (λi. (i, xs ! i)) [0..<length xs]"
  by (auto intro!: nth_equalityI)

lemma half_segments_of_aform_strict:
  assumes "e ∈ UNIV → {-1 <..< 1}"
  assumes "seg ∈ set (half_segments_of_aform X)"
  assumes "length (half_segments_of_aform X) ≠ 1"
  shows "ccw' (fst seg) (snd seg) (aform_val e X)"
  using assms unfolding half_segments_of_aform_def Let_def
proof -
  have len: "length (map ((*⇩_R) 2) (linorder_list0.selsort (ccw 0) (inl (snd X)))) ≠ 1"
    using assms by (auto simp: half_segments_of_aform_def)

  have "aform_val e X = fst X + pdevs_val e (snd X)"
    by (simp add: aform_val_def)
  also
  obtain e' where "e' ∈ UNIV → {-1 <..< 1}"
    "pdevs_val e (snd X) = pdevs_val e' (nlex_pdevs (snd X))"
    using pdevs_val_nlex_pdevs[OF ‹e ∈ _›]
    by auto
  note this(2)
  also obtain e'' where "e'' ∈ UNIV → {-1 <..< 1}"
    "… = pdevs_val e'' (pdevs_of_list (map snd (list_of_pdevs (nlex_pdevs (snd X)))))"
    by (metis pdevs_val_of_list_of_pdevs2[OF ‹e' ∈ _›])
  note this(2)
  also
  obtain e''' where "e''' ∈ UNIV → {-1 <..< 1}" "… = pdevs_val e''' (pdevs_of_list (inl (snd X)))"
    unfolding inl_def
    using
      pdevs_val_independent_pdevs_strict[OF list_all_list_of_pdevsI,
        OF lex_nlex_pdevs list_of_pdevs_all_nonzero ‹e'' ∈ _›]
    by metis
  note this(2)
  also
  from pdevs_val_selsort_ccw[OF distinct_inl ‹e''' ∈ _›]
  obtain f where "f ∈ UNIV → {-1 <..< 1}"
    "… = pdevs_val f (pdevs_of_list (linorder_list0.selsort (ccw 0) (inl (snd X))))"
    (is "_ = pdevs_val _ (pdevs_of_list ?sl)")
    by metis
  note this(2)
  also have "… = pdevs_val (λi. f i + 1) (pdevs_of_list ?sl) +
      lowest_vertex (fst X, nlex_pdevs (snd X)) - fst X"
  proof -
    have "sum_list (dense_list_of_pdevs (nlex_pdevs (snd X))) =
        sum_list (dense_list_of_pdevs (pdevs_of_list (ccw.selsort 0 (inl (snd X)))))"
      by (subst dense_list_of_pdevs_pdevs_of_list)
        (auto simp: in_set_independent_pdevs_nonzero dense_list_of_pdevs_pdevs_of_list inl_def
          sum_list_distinct_selsort sum_list_independent_pdevs sum_list_list_of_pdevs)
    thus ?thesis
      by (auto simp add: pdevs_val_add lowest_vertex_def algebra_simps pdevs_val_sum_list
        sum_list_list_of_pdevs in_set_inl_nonzero dense_list_of_pdevs_pdevs_of_list)
  qed
  also have "pdevs_val (λi. f i + 1) (pdevs_of_list ?sl) =
      pdevs_val (λi. 1/2 * (f i + 1)) (pdevs_of_list (map ((*⇩_R) 2) ?sl))"
    (is "_ = pdevs_val ?f' (pdevs_of_list ?ssl)")
    by (subst pdevs_val_cmul) (simp add: pdevs_of_list_map_scaleR)
  also
  have "distinct ?ssl" "?f' ∈ UNIV → {0<..<1}" using ‹f ∈ _›
    by (auto simp: distinct_map_scaleRI Pi_iff algebra_simps real_0_less_add_iff)
  from pdevs_of_list_sum[OF this]
  obtain g where "g ∈ UNIV → {0<..<1}"
    "pdevs_val ?f' (pdevs_of_list ?ssl) = (∑P∈set ?ssl. g P *⇩_R P)"
    by blast
  note this(2)
  finally
  have "aform_val e X = lowest_vertex (fst X, nlex_pdevs (snd X)) + (∑P∈set ?ssl. g P *⇩_R P)"
    by simp
  also
  have "ccw' (fst seg) (snd seg) …"
    using ‹g ∈ _› _ len ‹seg ∈ _›[unfolded half_segments_of_aform_def Let_def]
    by (rule in_polychain_of_ccw) (simp add: ccw'_sortedP_scaled_inl)
  finally show ?thesis .
qed

lemma half_segments_of_aform_strict_all:
  assumes "e ∈ UNIV → {-1 <..< 1}"
  assumes "length (half_segments_of_aform X) ≠ 1"
  shows "list_all (λseg. ccw' (fst seg) (snd seg) (aform_val e X)) (half_segments_of_aform X)"
  using assms
  by (auto intro!: half_segments_of_aform_strict simp: list_all_iff)

lemma list_allD: "list_all P xs ⟹ x ∈ set xs ⟹ P x"
  by (auto simp: list_all_iff)

lemma minus_one_less_multI:
  fixes e x::real
  shows "- 1 ≤ e ⟹ 0 < x ⟹ x < 1 ⟹ - 1 < e * x"
  by (metis abs_add_one_gt_zero abs_real_def le_less_trans less_not_sym mult_less_0_iff
    mult_less_cancel_left1 real_0_less_add_iff)

lemma less_one_multI:
  fixes e x::real
  shows "e ≤ 1 ⟹ 0 < x ⟹ x < 1 ⟹ e * x < 1"
  by (metis (erased, hide_lams) less_eq_real_def monoid_mult_class.mult.left_neutral
    mult_strict_mono zero_less_one)

lemma ccw_half_segments_of_aform_strictI:
  assumes "e ∈ UNIV → {-1 <..< 1}"
  assumes "(s1, s2) ∈ set (half_segments_of_aform X)"
  assumes "length (half_segments_of_aform X) ≠ 1"
  assumes "x = (aform_val e X)"
  shows "ccw' s1 s2 x"
  using half_segments_of_aform_strict[OF assms(1-3)] assms(4) by simp

lemma
  ccw'_sortedP_subsequent:
  assumes "Suc i < length xs" "ccw'.sortedP 0 (map dirvec xs)" "fst (xs ! Suc i) = snd (xs ! i)"
  shows "ccw' (fst (xs ! i)) (snd (xs ! i)) (snd (xs ! Suc i))"
  using assms
proof (induct xs arbitrary: i)
  case Nil thus ?case by simp
next
  case (Cons x xs)
  thus ?case
    by (auto simp: nth_Cons dirvec_minus split: nat.split elim!: ccw'.sortedP_Cons)
      (metis (no_types, lifting) ccw'.renormalize length_greater_0_conv nth_mem prod.case_eq_if)
qed

lemma ccw'_sortedP_uminus: "ccw'.sortedP 0 xs ⟹ ccw'.sortedP 0 (map uminus xs)"
  by (induct xs) (auto intro!: ccw'.sortedP.Cons elim!: ccw'.sortedP_Cons simp del: uminus_Pair)

lemma subsequent_half_segments_ccw:
  fixes X
  assumes "Suc i < length (half_segments_of_aform X)"
  shows "ccw' (fst (half_segments_of_aform X ! i)) (snd (half_segments_of_aform X ! i))
    (snd (half_segments_of_aform X ! Suc i))"
  using assms
  by (intro ccw'_sortedP_subsequent )
    (auto simp: subsequent_half_segments half_segments_of_aform_def
      sorted_inl polychain_of_subsequent_eq intro!: ccw_sorted_implies_ccw'_sortedP[OF inl_ncoll]
      ccw'_sorted_scaleR)

lemma convex_polychain_half_segments_of_aform: "convex_polychain (half_segments_of_aform X)"
proof cases
  assume "length (half_segments_of_aform X) = 1"
  thus ?thesis
    by (auto simp: length_Suc_conv convex_polychain_def polychain_def)
next
  assume len: "length (half_segments_of_aform X) ≠ 1"
  show ?thesis
    by (rule convex_polychainI)
      (simp_all add: polychain_half_segments_of_aform subsequent_half_segments_ccw
        ccw'_def[symmetric])
qed

lemma hd_distinct_neq_last: "distinct xs ⟹ length xs > 1 ⟹ hd xs ≠ last xs"
  by (metis One_nat_def add_Suc_right distinct.simps(2) last.simps last_in_set less_irrefl
    list.exhaust list.sel(1) list.size(3) list.size(4) add.right_neutral nat_neq_iff not_less0)

lemma ccw_hd_last_half_segments_dirvec:
  assumes "length (half_segments_of_aform X) > 1"
  shows "ccw' 0 (dirvec (hd (half_segments_of_aform X))) (dirvec (last (half_segments_of_aform X)))"
proof -
  let ?i = "ccw.selsort 0 (inl (snd X))"
  let ?s = "map ((*⇩_R) 2) (ccw.selsort 0 (inl (snd X)))"
  from assms have l: "1 < length (inl (snd X))" "inl (snd X) ≠ []"
    using assms by (auto simp add: half_segments_of_aform_def)
  hence "hd ?i ∈ set ?i" "last ?i ∈ set ?i"
    by (auto intro!: hd_in_set last_in_set simp del: ccw.set_selsort)
  hence "¬coll 0 (hd ?i) (last ?i)" using l
    by (intro inl_ncoll[of _ X]) (auto simp: hd_distinct_neq_last)
  hence "¬coll 0 (hd ?s) (last ?s)" using l
    by (auto simp: hd_map last_map)
  hence "ccw' 0 (hd (map ((*⇩_R) 2) (linorder_list0.selsort (ccw 0) (inl (snd X)))))
     (last (map ((*⇩_R) 2) (linorder_list0.selsort (ccw 0) (inl (snd X)))))"
    using assms
    by (auto simp add: half_segments_of_aform_def
      intro!: sorted_inl ccw_sorted_scaleR ccw.hd_last_sorted ccw_ncoll_imp_ccw)
  with assms show ?thesis
    by (auto simp add: half_segments_of_aform_def Let_def
        dirvec_hd_polychain_of dirvec_last_polychain_of length_greater_0_conv[symmetric]
      simp del: polychain_of.simps length_greater_0_conv
      split: if_split_asm)
qed

lemma map_fst_half_segments_aux_eq: "[] ≠ half_segments_of_aform X ⟹
    map fst (half_segments_of_aform X) =
      fst (hd (half_segments_of_aform X))#butlast (map snd (half_segments_of_aform X))"
  by (rule nth_equalityI)
    (auto simp: nth_Cons hd_conv_nth nth_butlast subsequent_half_segments split: nat.split)

lemma le_less_Suc_eq: "x - Suc 0 ≤ (i::nat) ⟹ i < x ⟹ x - Suc 0 = i"
  by simp

lemma map_snd_half_segments_aux_eq: "half_segments_of_aform X ≠ [] ⟹
    map snd (half_segments_of_aform X) =
      tl (map fst (half_segments_of_aform X)) @ [snd (last (half_segments_of_aform X))]"
  by (rule nth_equalityI)
    (auto simp: nth_Cons hd_conv_nth nth_append nth_tl subsequent_half_segments
      not_less last_conv_nth algebra_simps dest!: le_less_Suc_eq
    split: nat.split)

lemma ccw'_sortedP_snd_half_segments_of_aform:
  "ccw'.sortedP (lowest_vertex (fst X, nlex_pdevs (snd X))) (map snd (half_segments_of_aform X))"
  by (auto simp: half_segments_of_aform_def Let_def
    intro!: ccw'.sortedP.Cons ccw'_sortedP_polychain_of_snd ccw'_sortedP_scaled_inl)

lemma
  lex_half_segments_lowest_vertex:
  assumes "(c, d) ∈ set (half_segments_of_aform X)"
  shows "lex d (lowest_vertex (fst X, nlex_pdevs (snd X)))"
  unfolding half_segments_of_aform_def Let_def
  by (rule lex_polychain_of_center[OF assms[unfolded half_segments_of_aform_def Let_def],
      unfolded snd_conv])
    (auto simp: list_all_iff lex_def dest!: in_set_inl_lex)

lemma
  lex_half_segments_lowest_vertex':
  assumes "d ∈ set (map snd (half_segments_of_aform X))"
  shows "lex d (lowest_vertex (fst X, nlex_pdevs (snd X)))"
  using assms
  by (auto intro: lex_half_segments_lowest_vertex)

lemma
  lex_half_segments_last:
  assumes "(c, d) ∈ set (half_segments_of_aform X)"
  shows "lex (snd (last (half_segments_of_aform X))) d"
  using assms
  unfolding half_segments_of_aform_def Let_def
  by (rule lex_polychain_of_last) (auto simp: list_all_iff lex_def dest!: in_set_inl_lex)

lemma
  lex_half_segments_last':
  assumes "d ∈ set (map snd (half_segments_of_aform X))"
  shows "lex (snd (last (half_segments_of_aform X))) d"
  using assms
  by (auto intro: lex_half_segments_last)

lemma
  ccw'_half_segments_lowest_last:
  assumes set_butlast: "(c, d) ∈ set (butlast (half_segments_of_aform X))"
  assumes ne: "inl (snd X) ≠ []"
  shows "ccw' (lowest_vertex (fst X, nlex_pdevs (snd X))) d (snd (last (half_segments_of_aform X)))"
  using set_butlast
  unfolding half_segments_of_aform_def Let_def
  by (rule ccw'_polychain_of_sorted_center_last) (auto simp: ne ccw'_sortedP_scaled_inl)

lemma distinct_fst_half_segments:
  "distinct (map fst (half_segments_of_aform X))"
  by (auto simp: half_segments_of_aform_def list_all_iff lex_scale1_zero
    simp del: scaleR_Pair
    intro!: distinct_fst_polychain_of
    dest: in_set_inl_nonzero in_set_inl_lex)

lemma distinct_snd_half_segments:
  "distinct (map snd (half_segments_of_aform X))"
  by (auto simp: half_segments_of_aform_def list_all_iff lex_scale1_zero
    simp del: scaleR_Pair
    intro!: distinct_snd_polychain_of
    dest: in_set_inl_nonzero in_set_inl_lex)


subsection ‹Mirror›

definition "mirror_point x y = 2 *⇩_R x - y"

lemma ccw'_mirror_point3[simp]:
  "ccw' (mirror_point x y) (mirror_point x z) (mirror_point x w) ⟷ ccw' y z w "
  by (auto simp: mirror_point_def det3_def' ccw'_def algebra_simps)

lemma mirror_point_self_inverse[simp]:
  fixes x::"'a::real_vector"
  shows "mirror_point p (mirror_point p x) = x"
  by (auto simp: mirror_point_def scaleR_2)

lemma mirror_half_segments_of_aform:
  assumes "e ∈ UNIV → {-1 <..< 1}"
  assumes "length (half_segments_of_aform X) ≠ 1"
  shows "list_all (λseg. ccw' (fst seg) (snd seg) (aform_val e X))
      (map (pairself (mirror_point (fst X))) (half_segments_of_aform X))"
  unfolding list_all_length
proof safe
  let ?m = "map (pairself (mirror_point (fst X))) (half_segments_of_aform X)"
  fix n assume "n < length ?m"
  hence "ccw' (fst (half_segments_of_aform X ! n)) (snd (half_segments_of_aform X ! n))
      (aform_val (- e) X)"
    using assms
    by (auto dest!: nth_mem intro!: half_segments_of_aform_strict)
  also have "aform_val (-e) X = 2 *⇩_R fst X - aform_val e X"
    by (auto simp: aform_val_def pdevs_val_sum algebra_simps scaleR_2 sum_negf)
  finally have le:
    "ccw' (fst (half_segments_of_aform X ! n)) (snd (half_segments_of_aform X ! n))
      (2 *⇩_R fst X - aform_val e X)"
    .

  have eq: "(map (pairself (mirror_point (fst X))) (half_segments_of_aform X) ! n) =
    (2 *⇩_R fst X - fst ((half_segments_of_aform X) ! n),
     2 *⇩_R fst X - snd ((half_segments_of_aform X) ! n))"
    using ‹n < length ?m›
    by (cases "half_segments_of_aform X ! n") (auto simp add: mirror_point_def)
  show "ccw' (fst (?m ! n)) (snd (?m ! n)) (aform_val e X)"
    using le
    unfolding eq
    by (auto simp: algebra_simps ccw'_def det3_def')
qed

lemma last_half_segments:
  assumes "half_segments_of_aform X ≠ []"
  shows "snd (last (half_segments_of_aform X)) =
    mirror_point (fst X) (lowest_vertex (fst X, nlex_pdevs (snd X)))"
  using assms
  by (auto simp add: half_segments_of_aform_def Let_def lowest_vertex_def mirror_point_def scaleR_2
    scaleR_sum_list[symmetric] last_polychain_of sum_list_distinct_selsort inl_def
    sum_list_independent_pdevs sum_list_list_of_pdevs)

lemma convex_polychain_map_mirror:
  assumes "convex_polychain hs"
  shows "convex_polychain (map (pairself (mirror_point x)) hs)"
proof (rule convex_polychainI)
qed (insert assms, auto simp: convex_polychain_def polychain_map_pairself pairself_apply
  mirror_point_def det3_def' algebra_simps)

lemma ccw'_mirror_point0:
  "ccw' (mirror_point x y) z w ⟷ ccw' y (mirror_point x z) (mirror_point x w)"
  by (metis ccw'_mirror_point3 mirror_point_self_inverse)

lemma ccw'_sortedP_mirror:
  "ccw'.sortedP x0 (map (mirror_point p0) xs) ⟷ ccw'.sortedP (mirror_point p0 x0) xs"
  by (induct xs)
    (simp_all add: linorder_list0.sortedP.Nil linorder_list0.sortedP_Cons_iff ccw'_mirror_point0)

lemma ccw'_sortedP_mirror2:
  "ccw'.sortedP (mirror_point p0 x0) (map (mirror_point p0) xs) ⟷ ccw'.sortedP x0 xs"
  using ccw'_sortedP_mirror[of "mirror_point p0 x0" p0 xs]
  by simp

lemma map_mirror_o_snd_polychain_of_eq: "map (mirror_point x0 ∘ snd) (polychain_of y xs) =
  map snd (polychain_of (mirror_point x0 y) (map uminus xs))"
  by (induct xs arbitrary: x0 y) (auto simp: mirror_point_def o_def algebra_simps)

lemma lowest_vertex_eq_mirror_last:
  "half_segments_of_aform X ≠ [] ⟹
    (lowest_vertex (fst X, nlex_pdevs (snd X))) =
    mirror_point (fst X) (snd (last (half_segments_of_aform X)))"
  using last_half_segments[of X] by simp

lemma snd_last: "xs ≠ [] ⟹ snd (last xs) = last (map snd xs)"
  by (induct xs) auto

lemma mirror_point_snd_last_eq_lowest:
  "half_segments_of_aform X ≠ [] ⟹
    mirror_point (fst X) (last (map snd (half_segments_of_aform X))) =
      lowest_vertex (fst X, nlex_pdevs (snd X))"
  by (simp add: lowest_vertex_eq_mirror_last snd_last)

lemma lex_mirror_point: "lex (mirror_point x0 a) (mirror_point x0 b) ⟹ lex b a"
  by (auto simp: mirror_point_def lex_def)

lemma ccw'_mirror_point:
  "ccw' (mirror_point x0 a) (mirror_point x0 b)  (mirror_point x0 c) ⟹ ccw' a b c"
  by (auto simp: mirror_point_def)

lemma inj_mirror_point: "inj (mirror_point (x::'a::real_vector))"
  by (auto simp: mirror_point_def inj_on_def algebra_simps)

lemma
  distinct_map_mirror_point_eq:
  "distinct (map (mirror_point (x::'a::real_vector)) xs) = distinct xs"
  by (auto simp: distinct_map intro!: subset_inj_on[OF inj_mirror_point])

lemma eq_self_mirror_iff: fixes x::"'a::real_vector" shows "x = mirror_point y x ⟷ x = y"
  by (auto simp: mirror_point_def algebra_simps scaleR_2[symmetric])


subsection ‹Full Segments›

definition segments_of_aform::"point aform ⇒ (point * point) list"
  where "segments_of_aform X =
    (let hs = half_segments_of_aform X in hs @ map (pairself (mirror_point (fst X))) hs)"

lemma segments_of_aform_strict:
  assumes "e ∈ UNIV → {-1 <..< 1}"
  assumes "length (half_segments_of_aform X) ≠ 1"
  shows "list_all (λseg. ccw' (fst seg) (snd seg) (aform_val e X)) (segments_of_aform X)"
  using assms
  by (auto simp: segments_of_aform_def Let_def mirror_half_segments_of_aform
    half_segments_of_aform_strict_all)
  

lemma mirror_point_aform_val[simp]: "mirror_point (fst X) (aform_val e X) = aform_val (- e) X"
  by (auto simp: mirror_point_def aform_val_def pdevs_val_sum algebra_simps scaleR_2 sum_negf)

lemma
  in_set_segments_of_aform_aform_valE:
  assumes "(x2, y2) ∈ set (segments_of_aform X)"
  obtains e where "y2 = aform_val e X" "e ∈ UNIV → {-1 .. 1}"
  using assms
proof (auto simp: segments_of_aform_def Let_def)
  assume "(x2, y2) ∈ set (half_segments_of_aform X)"
  from in_set_half_segments_of_aform_aform_valE[OF this]
  obtain e where "y2 = aform_val e X" "e ∈ UNIV → {- 1..1}" by auto
  thus ?thesis ..
next
  fix a b aa ba
  assume "((a, b), aa, ba) ∈ set (half_segments_of_aform X)"
  from in_set_half_segments_of_aform_aform_valE[OF this]
  obtain e where e: "(aa, ba) = aform_val e X" "e ∈ UNIV → {- 1..1}" by auto
  assume "y2 = mirror_point (fst X) (aa, ba)"
  hence "y2 = aform_val (-e) X" "(-e) ∈ UNIV → {-1 .. 1}" using e by auto
  thus ?thesis ..
qed

lemma
  last_half_segments_eq_mirror_hd:
  assumes "half_segments_of_aform X ≠ []"
  shows "snd (last (half_segments_of_aform X)) = mirror_point (fst X) (fst (hd (half_segments_of_aform X)))"
  by (simp add: last_half_segments assms fst_hd_half_segments_of_aform)

lemma polychain_segments_of_aform: "polychain (segments_of_aform X)"
  by (auto simp: segments_of_aform_def Let_def polychain_half_segments_of_aform
    polychain_map_pairself last_half_segments_eq_mirror_hd hd_map pairself_apply
    intro!: polychain_appendI)

lemma segments_of_aform_closed:
  assumes "segments_of_aform X ≠ []"
  shows "fst (hd (segments_of_aform X)) = snd (last (segments_of_aform X))"
  using assms
  by (auto simp: segments_of_aform_def Let_def fst_hd_half_segments_of_aform last_map
    pairself_apply last_half_segments mirror_point_def)

lemma convex_polychain_segments_of_aform:
  assumes "1 < length (half_segments_of_aform X)"
  shows "convex_polychain (segments_of_aform X)"
  unfolding segments_of_aform_def Let_def
    using ccw_hd_last_half_segments_dirvec[OF assms]
  by (intro convex_polychain_appendI)
    (auto
      simp: convex_polychain_half_segments_of_aform convex_polychain_map_mirror dirvec_minus hd_map
        pairself_apply last_half_segments mirror_point_def fst_hd_half_segments_of_aform det3_def'
        algebra_simps ccw'_def
      intro!: polychain_appendI polychain_half_segments_of_aform polychain_map_pairself)

lemma convex_polygon_segments_of_aform:
  assumes "1 < length (half_segments_of_aform X)"
  shows "convex_polygon (segments_of_aform X)"
proof -
  from assms have hne: "half_segments_of_aform X ≠ []"
    by auto
  from convex_polychain_segments_of_aform[OF assms]
  have "convex_polychain (segments_of_aform X)" .
  thus ?thesis
    by (auto simp: convex_polygon_def segments_of_aform_closed)
qed

lemma
  previous_segments_of_aformE:
  assumes "(y, z) ∈ set (segments_of_aform X)"
  obtains x where "(x, y) ∈ set (segments_of_aform X)"
proof -
  from assms have ne[simp]: "segments_of_aform X ≠ []"
    by auto
  from assms
  obtain i where i: "i<length (segments_of_aform X)" "(segments_of_aform X) ! i = (y, z)"
    by (auto simp: in_set_conv_nth)
  show ?thesis
  proof (cases i)
    case 0
    with segments_of_aform_closed[of X] assms
    have "(fst (last (segments_of_aform X)), y) ∈ set (segments_of_aform X)"
      by (metis fst_conv hd_conv_nth i(2) last_in_set ne snd_conv surj_pair)
    thus ?thesis ..
  next
    case (Suc j)
    have "(fst (segments_of_aform X ! j), snd (segments_of_aform X ! j)) ∈
        set (segments_of_aform X)"
      using Suc i(1) by auto
    also
    from i have "y = fst (segments_of_aform X ! i)"
      by auto
    hence "snd (segments_of_aform X ! j) = y"
      using polychain_segments_of_aform[of X] i(1) Suc
      by (auto simp: polychain_def Suc)
    finally have "(fst (segments_of_aform X ! j), y) ∈ set (segments_of_aform X)" .
    thus ?thesis ..
  qed
qed

lemma fst_compose_pairself: "fst o pairself f = f o fst"
  and snd_compose_pairself: "snd o pairself f = f o snd"
  by (auto simp: pairself_apply)

lemma in_set_butlastI: "xs ≠ [] ⟹ x ∈ set xs ⟹ x ≠ last xs ⟹ x ∈ set (butlast xs)"
  by (induct xs) (auto split: if_splits)

lemma distinct_in_set_butlastD:
  "x ∈ set (butlast xs) ⟹ distinct xs ⟹ x ≠ last xs"
  by (induct xs) auto

lemma distinct_in_set_tlD:
  "x ∈ set (tl xs) ⟹ distinct xs ⟹ x ≠ hd xs"
  by (induct xs) auto

lemma ccw'_sortedP_snd_segments_of_aform:
  assumes "length (inl (snd X)) > 1"
  shows
    "ccw'.sortedP (lowest_vertex (fst X, nlex_pdevs (snd X)))
      (butlast (map snd (segments_of_aform X)))"
proof cases
  assume "[] = half_segments_of_aform X"
  from this show ?thesis
    by (simp add: segments_of_aform_def Let_def ccw'.sortedP.Nil)
next
  assume H: "[] ≠ half_segments_of_aform X"
  let ?m = "mirror_point (fst X)"
  have ne: "inl (snd X) ≠ []" using assms by auto
  have "ccw'.sortedP (lowest_vertex (fst X, nlex_pdevs (snd X)))
     (map snd (half_segments_of_aform X) @ butlast (map (?m ∘ snd)
    (half_segments_of_aform X)))"
  proof (rule ccw'.sortedP_appendI)
    show "ccw'.sortedP (lowest_vertex (fst X, nlex_pdevs (snd X))) (map snd (half_segments_of_aform X))"
      by (rule ccw'_sortedP_snd_half_segments_of_aform)
    have "butlast (map (?m ∘ snd) (half_segments_of_aform X)) =
      butlast
       (map (?m ∘ snd) (polychain_of (lowest_vertex (fst X, nlex_pdevs (snd X)))
         (map ((*⇩_R) 2) (ccw.selsort 0 (inl (snd X))))))"
      by (simp add: half_segments_of_aform_def)
    also have "… =
       map snd
        (butlast
          (polychain_of (?m (lowest_vertex (fst X, nlex_pdevs (snd X))))
            (map uminus (map ((*⇩_R) 2) (ccw.selsort 0 (inl (snd X)))))))"
      (is "_ = map snd (butlast (polychain_of ?x ?xs))")
      by (simp add: map_mirror_o_snd_polychain_of_eq map_butlast)
    also
    {
      have "ccw'.sortedP 0 ?xs"
        by (intro ccw'_sortedP_uminus ccw'_sortedP_scaled_inl)
      moreover
      have "ccw'.sortedP ?x (map snd (polychain_of ?x ?xs))"
        unfolding ccw'_sortedP_mirror[symmetric] map_map map_mirror_o_snd_polychain_of_eq
        by (auto simp add: o_def intro!: ccw'_sortedP_polychain_of_snd ccw'_sortedP_scaled_inl)
      ultimately
      have "ccw'.sortedP (snd (last (polychain_of ?x ?xs)))
          (map snd (butlast (polychain_of ?x ?xs)))"
        by (rule ccw'_sortedP_convex_rotate_aux)
    }
    also have "(snd (last (polychain_of ?x ?xs))) =
        ?m (last (map snd (half_segments_of_aform X)))"
      by (simp add: half_segments_of_aform_def ne map_mirror_o_snd_polychain_of_eq
         last_map[symmetric, where f="?m"]
         last_map[symmetric, where f="snd"])
    also have "… = lowest_vertex (fst X, nlex_pdevs (snd X))"
      using ne H
      by (auto simp: lowest_vertex_eq_mirror_last snd_last)
    finally show "ccw'.sortedP (lowest_vertex (fst X, nlex_pdevs (snd X)))
       (butlast (map (?m ∘ snd) (half_segments_of_aform X)))" .
  next
    fix x y
    assume seg: "x ∈ set (map snd (half_segments_of_aform X))"
      and mseg: "y ∈ set (butlast (map (?m ∘ snd) (half_segments_of_aform X)))"
    from seg assms have neq_Nil: "inl (snd X) ≠ []" "half_segments_of_aform X ≠ []"
      by auto

    from seg obtain a where a: "(a, x) ∈ set (half_segments_of_aform X)"
      by auto
    from mseg obtain b
    where mirror_y: "(b, ?m y) ∈ set (butlast (half_segments_of_aform X))"
      by (auto simp: map_butlast[symmetric])

    let ?l = "lowest_vertex (fst X, nlex_pdevs (snd X))"
    let ?ml = "?m ?l"

    have mirror_eq_last: "?ml = snd (last (half_segments_of_aform X))"
      using seg H
      by (intro last_half_segments[symmetric]) simp

    define r
      where "r = ?l + (0, abs (snd x - snd ?l) + abs (snd y - snd ?l) + abs (snd ?ml - snd ?l) + 1)"

    have d1: "x ≠ r" "y ≠ r" "?l ≠ r" "?ml ≠ r"
      by (auto simp: r_def plus_prod_def prod_eq_iff)
    have "distinct (map (?m ∘ snd) (half_segments_of_aform X))"
      unfolding map_comp_map[symmetric]
      unfolding o_def distinct_map_mirror_point_eq
      by (rule distinct_snd_half_segments)
    from distinct_in_set_butlastD[OF ‹y ∈ _› this]
    have "?l ≠ y"
      by (simp add: neq_Nil lowest_vertex_eq_mirror_last last_map)
    moreover have "?l ≠ ?ml"
      using neq_Nil by (auto simp add: eq_self_mirror_iff lowest_vertex_eq_center_iff inl_def)
    ultimately
    have d2: "?l ≠ y" "?l ≠ ?ml"
      by auto

    have *: "ccw' ?l (?m y) ?ml"
      by (metis mirror_eq_last ccw'_half_segments_lowest_last mirror_y neq_Nil(1))
    have "ccw' ?ml y ?l"
      by (rule ccw'_mirror_point[of "fst X"]) (simp add: *)
    hence lmy: "ccw' ?l ?ml y"
      by (simp add: ccw'_def det3_def' algebra_simps)
    let ?ccw = "ccw' (lowest_vertex (fst X, nlex_pdevs (snd X))) x y"
    {
      assume "x ≠ ?ml"
      hence x_butlast: "(a, x) ∈ set (butlast (half_segments_of_aform X))"
        unfolding mirror_eq_last
        using a
        by (auto intro!: in_set_butlastI simp: prod_eq_iff)
      have "ccw' ?l x ?ml"
        by (metis mirror_eq_last ccw'_half_segments_lowest_last x_butlast neq_Nil(1))
    } note lxml = this
    {
      assume "x = ?ml"
      hence ?ccw
        by (simp add: lmy)
    } moreover {
      assume "x ≠ ?ml" "y = ?ml"
      hence ?ccw
        by (simp add: lxml)
    } moreover {
      assume d3: "x ≠ ?ml" "y ≠ ?ml"

      from ‹x ∈ set _›
      have "x ∈ set (map snd (half_segments_of_aform X))" by force
      hence "x ∈ set (tl (map fst (half_segments_of_aform X)))"
        using d3
        unfolding map_snd_half_segments_aux_eq[OF neq_Nil(2)]
        by (auto simp: mirror_eq_last)
      from distinct_in_set_tlD[OF this distinct_fst_half_segments]
      have "?l ≠ x"
        by (simp add: fst_hd_half_segments_of_aform neq_Nil hd_map)

      from lxml[OF ‹x ≠ ?ml›] ‹ccw' ?l ?ml y›
      have d4: "x ≠ y"
        by (rule neq_left_right_of lxml)

      have "distinct5 x ?ml y r ?l"
        using d1 d2 ‹?l ≠ x› d3 d4
        by simp_all
      moreover
      note _
      moreover
      have "lex x ?l"
        by (rule lex_half_segments_lowest_vertex) fact
      hence "ccw ?l r x"
        unfolding r_def by (rule lex_ccw_left) simp
      moreover
      have "lex ?ml ?l"
        using last_in_set[OF H[symmetric]]
        by (auto simp: mirror_eq_last intro: lex_half_segments_lowest_vertex')
      hence "ccw ?l r ?ml"
        unfolding r_def by (rule lex_ccw_left) simp
      moreover
      have "lex (?m (lowest_vertex (fst X, nlex_pdevs (snd X)))) (?m y)"
        using mirror_y
        by (force dest!: in_set_butlastD intro: lex_half_segments_last' simp: mirror_eq_last )
      hence "lex y ?l"
        by (rule lex_mirror_point)
      hence "ccw ?l r y"
        unfolding r_def by (rule lex_ccw_left) simp
      moreover
      from ‹x ≠ ?ml› have "ccw ?l x ?ml"
        by (simp add: ccw_def lxml)
      moreover
      from lmy have "ccw ?l ?ml y"
        by (simp add: ccw_def)
      ultimately
      have "ccw ?l x y"
        by (rule ccw.transitive[where S=UNIV]) simp

      moreover
      {
        have "x ≠ ?l" using ‹?l ≠ x› by simp
        moreover
        have "lex (?m y) (?m ?ml)"
          using mirror_y
          by (force intro: lex_half_segments_lowest_vertex in_set_butlastD)
        hence "lex ?ml y"
          by (rule lex_mirror_point)
        moreover
        from a have "lex ?ml x"
          unfolding mirror_eq_last
          by (rule lex_half_segments_last)
        moreover note ‹lex y ?l› ‹lex x ?l› ‹ccw' ?l x ?ml› ‹ccw' ?l ?ml y›
        ultimately
        have ncoll: "¬ coll ?l x y"
          by (rule not_coll_ordered_lexI)
      }
      ultimately have ?ccw
        by (simp add: ccw_def)
    } ultimately show ?ccw
      by blast
  qed
  thus ?thesis using H
    by (simp add: segments_of_aform_def Let_def butlast_append snd_compose_pairself)
qed

lemma polychain_of_segments_of_aform1:
  assumes "length (segments_of_aform X) = 1"
  shows "False"
  using assms
  by (auto simp: segments_of_aform_def Let_def half_segments_of_aform_def add_is_1
    split: if_split_asm)

lemma polychain_of_segments_of_aform2:
  assumes "segments_of_aform X = [x, y]"
  assumes "between (fst x, snd x) p"
  shows "p ∈ convex hull set (map fst (segments_of_aform X))"
proof -
  from polychain_segments_of_aform[of X] segments_of_aform_closed[of X] assms
  have "fst y = snd x" "snd y = fst x" by (simp_all add: polychain_def)
  thus ?thesis
    using assms
    by (cases x) (auto simp: between_mem_convex_hull)
qed

lemma append_eq_2:
  assumes "length xs = length ys"
  shows "xs @ ys = [x, y] ⟷ xs = [x] ∧ ys = [y]"
  using assms
proof (cases xs)
  case (Cons z zs)
  thus ?thesis using assms by (cases zs) auto
qed simp

lemma segments_of_aform_line_segment:
  assumes "segments_of_aform X = [x, y]"
  assumes "e ∈ UNIV → {-1 .. 1}"
  shows "aform_val e X ∈ closed_segment (fst x) (snd x)"
proof -
  from pdevs_val_pdevs_of_list_inl2E[OF ‹e ∈ _›, of "snd X"]
  obtain e' where e': "pdevs_val e (snd X) = pdevs_val e' (pdevs_of_list (inl (snd X)))"
    "e' ∈ UNIV → {- 1..1}" .
  from e' have "0 ≤ 1 + e' 0" by (auto simp: Pi_iff dest!: spec[where x=0])
  with assms e' show ?thesis
    by (auto simp: segments_of_aform_def Let_def append_eq_2 half_segments_of_aform_def
        polychain_of_singleton_iff mirror_point_def ccw.selsort_singleton_iff lowest_vertex_def
        aform_val_def sum_list_nlex_eq_sum_list_inl closed_segment_def Pi_iff
      intro!: exI[where x="(1 + e' 0) / 2"])
      (auto simp: algebra_simps)
qed


subsection ‹Continuous Generalization›

lemma LIMSEQ_minus_fract_mult:
  "(λn. r * (1 - 1 / real (Suc (Suc n)))) ⇢ r"
  by (rule tendsto_eq_rhs[OF tendsto_mult[where a=r and b = 1]])
    (auto simp: inverse_eq_divide[symmetric] simp del: of_nat_Suc
      intro: filterlim_compose[OF LIMSEQ_inverse_real_of_nat filterlim_Suc] tendsto_eq_intros)

lemma det3_nonneg_segments_of_aform:
  assumes "e ∈ UNIV → {-1 .. 1}"
  assumes "length (half_segments_of_aform X) ≠ 1"
  shows "list_all (λseg. det3 (fst seg) (snd seg) (aform_val e X) ≥ 0) (segments_of_aform X)"
  unfolding list_all_iff
proof safe
  fix a b c d
  assume seg: "((a, b), c, d) ∈ set (segments_of_aform X)" (is "?seg ∈ _")
  define normal_of_segment
    where "normal_of_segment = (λ((a0, a1), b0, b1). (b1 - a1, a0 - b0)::real*real)"
  define support_of_segment
    where "support_of_segment = (λ(a, b). normal_of_segment (a, b) ∙ a)"
  have "closed ((λx. x ∙ normal_of_segment ?seg) -` {..support_of_segment ?seg})" (is "closed ?cl")
    by (auto intro!: continuous_intros closed_vimage)
  moreover
  define f where "f n i = e i * ( 1 - 1 / (Suc (Suc n)))" for n i
  have "∀n. aform_val (f n) X ∈ ?cl"
  proof
    fix n
    have "f n ∈ UNIV → {-1 <..< 1}"
      using assms
      by (auto simp: f_def Pi_iff intro!: less_one_multI minus_one_less_multI)
    from list_allD[OF segments_of_aform_strict[OF this assms(2)] seg]
    show "aform_val (f n) X ∈ (λx. x ∙ normal_of_segment ((a, b), c, d)) -`
        {..support_of_segment ((a, b), c, d)}"
      by (auto simp: list_all_iff normal_of_segment_def support_of_segment_def
        det3_def' field_simps inner_prod_def ccw'_def)
  qed
  moreover
  have "⋀i. (λn. f n i) ⇢ e i"
    unfolding f_def
    by (rule LIMSEQ_minus_fract_mult)
  hence "(λn. aform_val (f n) X) ⇢ aform_val e X"
    by (auto simp: aform_val_def pdevs_val_sum intro!: tendsto_intros)
  ultimately have "aform_val e X ∈ ?cl"
    by (rule closed_sequentially)
  thus "det3 (fst ?seg) (snd ?seg) (aform_val e X) ≥ 0"
    by (auto simp: list_all_iff normal_of_segment_def support_of_segment_def det3_def' field_simps
      inner_prod_def)
qed

lemma det3_nonneg_segments_of_aformI:
  assumes "e ∈ UNIV → {-1 .. 1}"
  assumes "length (half_segments_of_aform X) ≠ 1"
  assumes "seg ∈ set (segments_of_aform X)"
  shows "det3 (fst seg) (snd seg) (aform_val e X) ≥ 0"
  using assms det3_nonneg_segments_of_aform by (auto simp: list_all_iff)


subsection ‹Intersection of Vertical Line with Segment›

fun intersect_segment_xline'::"nat ⇒ point * point ⇒ real ⇒ point option"
  where "intersect_segment_xline' p ((x0, y0), (x1, y1)) xl =
    (if x0 ≤ xl ∧ xl ≤ x1 then
      if x0 = x1 then Some ((min y0 y1), (max y0 y1))
      else
        let
          yl = truncate_down p (truncate_down p (real_divl p (y1 - y0) (x1 - x0) * (xl - x0)) + y0);
          yr = truncate_up p (truncate_up p (real_divr p (y1 - y0) (x1 - x0) * (xl - x0)) + y0)
        in Some (yl, yr)
    else None)"

lemma norm_pair_fst0[simp]: "norm (0, x) = norm x"
  by (auto simp: norm_prod_def)

lemmas add_right_mono_le = order_trans[OF add_right_mono]
lemmas mult_right_mono_le = order_trans[OF mult_right_mono]

lemmas add_right_mono_ge = order_trans[OF _ add_right_mono]
lemmas mult_right_mono_ge = order_trans[OF _ mult_right_mono]

lemma dest_segment:
  fixes x b::real
  assumes "(x, b) ∈ closed_segment (x0, y0) (x1, y1)"
  assumes "x0 ≠ x1"
  shows "b = (y1 - y0) * (x - x0) / (x1 - x0) + y0"
proof -
  from assms obtain u where u: "x = x0 *⇩_R (1 - u) + u * x1" "b = y0 *⇩_R (1 - u) + u * y1" "0 ≤ u" "u ≤ 1"
    by (auto simp: closed_segment_def algebra_simps)
  show "b = (y1 - y0) * (x - x0) / (x1 - x0) + y0 "
    using assms by (auto simp: closed_segment_def field_simps u)
qed

lemma intersect_segment_xline':
  assumes "intersect_segment_xline' prec (p0, p1) x = Some (m, M)"
  shows "closed_segment p0 p1 ∩ {p. fst p = x} ⊆ {(x, m) .. (x, M)}"
  using assms
proof (cases p0)
  case (Pair x0 y0) note p0 = this
  show ?thesis
  proof (cases p1)
    case (Pair x1 y1) note p1 = this
    {
      assume "x0 = x1" "x = x1" "m = min y0 y1" "M = max y0 y1"
      hence ?thesis
        by (force simp: abs_le_iff p0 p1 min_def max_def algebra_simps dest: segment_bound
          split: if_split_asm)
    } thus ?thesis
      using assms
      by (auto simp: abs_le_iff p0 p1 split: if_split_asm
        intro!: truncate_up_le truncate_down_le
        add_right_mono_le[OF truncate_down]
        add_right_mono_le[OF real_divl]
        add_right_mono_le[OF mult_right_mono_le[OF real_divl]]
        add_right_mono_ge[OF _ truncate_up]
        add_right_mono_ge[OF _ mult_right_mono_ge[OF _ real_divr]]
        dest!: dest_segment)
  qed
qed

lemma
  in_segment_fst_le:
  fixes x0 x1 b::real
  assumes "x0 ≤ x1" "(x, b) ∈ closed_segment (x0, y0) (x1, y1)"
  shows "x ≤ x1"
  using assms using mult_left_mono[OF ‹x0 ≤ x1›, where c="1 - u" for u]
  by (force simp add: min_def max_def split: if_split_asm
    simp add: algebra_simps not_le closed_segment_def)

lemma
  in_segment_fst_ge:
  fixes x0 x1 b::real
  assumes "x0 ≤ x1" "(x, b) ∈ closed_segment (x0, y0) (x1, y1)"
  shows "x0 ≤ x"
  using assms using mult_left_mono[OF ‹x0 ≤ x1›]
  by (force simp add: min_def max_def split: if_split_asm
    simp add: algebra_simps not_le closed_segment_def)

lemma intersect_segment_xline'_eq_None:
  assumes "intersect_segment_xline' prec (p0, p1) x = None"
  assumes "fst p0 ≤ fst p1"
  shows "closed_segment p0 p1 ∩ {p. fst p = x} = {}"
  using assms
  by (cases p0, cases p1)
    (auto simp: abs_le_iff split: if_split_asm dest: in_segment_fst_le in_segment_fst_ge)

fun intersect_segment_xline
  where "intersect_segment_xline prec ((a, b), (c, d)) x =
  (if a ≤ c then intersect_segment_xline' prec ((a, b), (c, d)) x
  else intersect_segment_xline' prec ((c, d), (a, b)) x)"

lemma closed_segment_commute: "closed_segment a b = closed_segment b a"
  by (meson convex_contains_segment convex_closed_segment dual_order.antisym ends_in_segment)

lemma intersect_segment_xline:
  assumes "intersect_segment_xline prec (p0, p1) x = Some (m, M)"
  shows "closed_segment p0 p1 ∩ {p. fst p = x} ⊆ {(x, m) .. (x, M)}"
  using assms
  by (cases p0, cases p1)
    (auto simp: closed_segment_commute split: if_split_asm simp del: intersect_segment_xline'.simps
      dest!: intersect_segment_xline')

lemma intersect_segment_xline_fst_snd:
  assumes "intersect_segment_xline prec seg x = Some (m, M)"
  shows "closed_segment (fst seg) (snd seg) ∩ {p. fst p = x} ⊆ {(x, m) .. (x, M)}"
  using intersect_segment_xline[of prec "fst seg" "snd seg" x m M] assms
  by simp

lemma intersect_segment_xline_eq_None:
  assumes "intersect_segment_xline prec (p0, p1) x = None"
  shows "closed_segment p0 p1 ∩ {p. fst p = x} = {}"
  using assms
  by (cases p0, cases p1)
     (auto simp: closed_segment_commute split: if_split_asm simp del: intersect_segment_xline'.simps
      dest!: intersect_segment_xline'_eq_None)

lemma inter_image_empty_iff: "(X ∩ {p. f p = x} = {}) ⟷ (x ∉ f ` X)"
  by auto

lemma fst_closed_segment[simp]: "fst ` closed_segment a b = closed_segment (fst a) (fst b)"
  by (force simp: closed_segment_def)

lemma intersect_segment_xline_eq_empty:
  fixes p0 p1::"real * real"
  assumes "closed_segment p0 p1 ∩ {p. fst p = x} = {}"
  shows "intersect_segment_xline prec (p0, p1) x = None"
  using assms
  by (cases p0, cases p1)
    (auto simp: inter_image_empty_iff closed_segment_eq_real_ivl split: if_split_asm)

lemma intersect_segment_xline_le:
  assumes "intersect_segment_xline prec y xl = Some (m0, M0)"
  shows "m0 ≤ M0"
  using assms
  by (cases y) (auto simp: min_def split: if_split_asm intro!: truncate_up_le truncate_down_le
    order_trans[OF real_divl] order_trans[OF _ real_divr] mult_right_mono)

lemma intersect_segment_xline_None_iff:
  fixes p0 p1::"real * real"
  shows "intersect_segment_xline prec (p0, p1) x = None ⟷ closed_segment p0 p1 ∩ {p. fst p = x} = {}"
  by (auto intro!: intersect_segment_xline_eq_empty dest!: intersect_segment_xline_eq_None)


subsection ‹Bounds on Vertical Intersection with Oriented List of Segments›

primrec bound_intersect_2d where
  "bound_intersect_2d prec [] x = None"
| "bound_intersect_2d prec (X # Xs) xl =
    (case bound_intersect_2d prec Xs xl of
      None ⇒ intersect_segment_xline prec X xl
    | Some (m, M) ⇒
      (case intersect_segment_xline prec X xl of
        None ⇒ Some (m, M)
      | Some (m', M') ⇒ Some (min m' m, max M' M)))"

lemma
  bound_intersect_2d_eq_None:
  assumes "bound_intersect_2d prec Xs x = None"
  assumes "X ∈ set Xs"
  shows "intersect_segment_xline prec X x = None"
  using assms by (induct Xs) (auto split: option.split_asm)

lemma bound_intersect_2d_upper:
  assumes "bound_intersect_2d prec Xs x = Some (m, M)"
  obtains X m' where "X ∈ set Xs" "intersect_segment_xline prec X x = Some (m', M)"
    "⋀X m' M' . X ∈ set Xs ⟹ intersect_segment_xline prec X x = Some (m', M') ⟹ M' ≤ M"
proof atomize_elim
  show "∃X m'. X ∈ set Xs ∧ intersect_segment_xline prec X x = Some (m', M) ∧
    (∀X m' M'. X ∈ set Xs ⟶ intersect_segment_xline prec X x = Some (m', M') ⟶ M' ≤ M)"
    using assms
  proof (induct Xs arbitrary: m M)
    case Nil thus ?case by (simp add: bound_intersect_2d_def)
  next
    case (Cons X Xs)
    show ?case
    proof (cases "bound_intersect_2d prec Xs x")
      case None
      thus ?thesis using Cons
        by (intro exI[where x=X] exI[where x=m])
          (simp del: intersect_segment_xline.simps add: bound_intersect_2d_eq_None)
    next
      case (Some mM)
      note Some1=this
      then obtain m' M' where mM: "mM = (m', M')" by (cases mM)
      from Cons(1)[OF Some[unfolded mM]]
      obtain X' m'' where X': "X' ∈ set Xs"
        and m'': "intersect_segment_xline prec X' x = Some (m'', M')"
        and max: "⋀X m' M'a. X ∈ set Xs ⟹ intersect_segment_xline prec X x = Some (m', M'a) ⟹
          M'a ≤ M'"
        by auto
      show ?thesis
      proof (cases "intersect_segment_xline prec X x")
        case None thus ?thesis using Some1 mM Cons(2) X' m'' max
          by (intro exI[where x= X'] exI[where x= m''])
            (auto simp del: intersect_segment_xline.simps split: option.split_asm)
      next
        case (Some mM''')
        thus ?thesis using Some1 mM Cons(2) X' m''
          by (cases mM''')
            (force simp: max_def min_def simp del: intersect_segment_xline.simps
              split: option.split_asm if_split_asm dest!: max
              intro!: exI[where x= "if M' ≥ snd mM''' then X' else X"]
              exI[where x= "if M' ≥ snd mM''' then m'' else fst mM'''"])
      qed
    qed
  qed
qed

lemma bound_intersect_2d_lower:
  assumes "bound_intersect_2d prec Xs x = Some (m, M)"
  obtains X M' where "X ∈ set Xs" "intersect_segment_xline prec X x = Some (m, M')"
    "⋀X m' M' . X ∈ set Xs ⟹ intersect_segment_xline prec X x = Some (m', M') ⟹ m ≤ m'"
proof atomize_elim
  show "∃X M'. X ∈ set Xs ∧ intersect_segment_xline prec X x = Some (m, M') ∧
    (∀X m' M'. X ∈ set Xs ⟶ intersect_segment_xline prec X x = Some (m', M') ⟶ m ≤ m')"
    using assms
  proof (induct Xs arbitrary: m M)
    case Nil thus ?case by (simp add: bound_intersect_2d_def)
  next
    case (Cons X Xs)
    show ?case
    proof (cases "bound_intersect_2d prec Xs x")
      case None
      thus ?thesis using Cons
        by (intro exI[where x= X])
          (simp del: intersect_segment_xline.simps add: bound_intersect_2d_eq_None)
    next
      case (Some mM)
      note Some1=this
      then obtain m' M' where mM: "mM = (m', M')" by (cases mM)
      from Cons(1)[OF Some[unfolded mM]]
      obtain X' M'' where X': "X' ∈ set Xs"
        and M'': "intersect_segment_xline prec X' x = Some (m', M'')"
        and min: "⋀X m'a M'. X ∈ set Xs ⟹ intersect_segment_xline prec X x = Some (m'a, M') ⟹
          m' ≤ m'a"
        by auto
      show ?thesis
      proof (cases "intersect_segment_xline prec X x")
        case None thus ?thesis using Some1 mM Cons(2) X' M'' min
          by (intro exI[where x= X'] exI[where x= M''])
            (auto simp del: intersect_segment_xline.simps split: option.split_asm)
      next
        case (Some mM''')
        thus ?thesis using Some1 mM Cons(2) X' M'' min
          by (cases mM''')
            (force simp: max_def min_def
              simp del: intersect_segment_xline.simps
              split: option.split_asm if_split_asm
              dest!: min
              intro!: exI[where x= "if m' ≤ fst mM''' then X' else X"]
                exI[where x= "if m' ≤ fst mM''' then M'' else snd mM'''"])
      qed
    qed
  qed
qed

lemma bound_intersect_2d:
  assumes "bound_intersect_2d prec Xs x = Some (m, M)"
  shows "(⋃(p1, p2) ∈ set Xs. closed_segment p1 p2) ∩ {p. fst p = x} ⊆ {(x, m) .. (x, M)}"
proof (clarsimp, safe)
  fix b x0 y0 x1 y1
  assume H: "((x0, y0), x1, y1) ∈ set Xs" "(x, b) ∈ closed_segment (x0, y0) (x1, y1)"
  hence "intersect_segment_xline prec ((x0, y0), x1, y1) x ≠ None"
    by (intro notI)
      (auto dest!: intersect_segment_xline_eq_None simp del: intersect_segment_xline.simps)
  then obtain e f where ef: "intersect_segment_xline prec ((x0, y0), x1, y1) x = Some (e, f)"
    by auto
  with H have "m ≤ e"
    by (auto intro: bound_intersect_2d_lower[OF assms])
  also have "… ≤ b"
    using intersect_segment_xline[OF ef] H
    by force
  finally show "m ≤ b" .
  have "b ≤ f"
    using intersect_segment_xline[OF ef] H
    by force
  also have "… ≤ M"
    using H ef by (auto intro: bound_intersect_2d_upper[OF assms])
  finally show "b ≤ M" .
qed

lemma bound_intersect_2d_eq_None_iff:
  "bound_intersect_2d prec Xs x = None ⟷ (∀X∈set Xs. intersect_segment_xline prec X x = None)"
  by (induct Xs) (auto simp: split: option.split_asm)

lemma bound_intersect_2d_nonempty:
  assumes "bound_intersect_2d prec Xs x = Some (m, M)"
  shows "(⋃(p1, p2) ∈ set Xs. closed_segment p1 p2) ∩ {p. fst p = x} ≠ {}"
proof -
  from assms have "bound_intersect_2d prec Xs x ≠ None" by simp
  then obtain p1 p2 where "(p1, p2) ∈ set Xs" "intersect_segment_xline prec (p1, p2) x ≠ None"
    unfolding bound_intersect_2d_eq_None_iff by auto
  hence "closed_segment p1 p2 ∩ {p. fst p = x} ≠ {}"
    by (simp add: intersect_segment_xline_None_iff)
  thus ?thesis using ‹(p1, p2) ∈ set Xs› by auto
qed

lemma bound_intersect_2d_le:
  assumes "bound_intersect_2d prec Xs x = Some (m, M)" shows "m ≤ M"
proof -
  from bound_intersect_2d_nonempty[OF assms] bound_intersect_2d[OF assms]
  show "m ≤ M" by auto
qed


subsection ‹Bounds on Vertical Intersection with General List of Segments›

definition "bound_intersect_2d_ud prec X xl =
  (case segments_of_aform X of
    [] ⇒ if fst (fst X) = xl then let m = snd (fst X) in Some (m, m) else None
  | [x, y] ⇒ intersect_segment_xline prec x xl
  | xs ⇒
    (case bound_intersect_2d prec (filter (λ((x1, y1), x2, y2). x1 < x2) xs) xl of
      Some (m, M') ⇒
      (case bound_intersect_2d prec (filter (λ((x1, y1), x2, y2). x1 > x2) xs) xl of
        Some (m', M) ⇒ Some (min m m', max M M')
      | None ⇒ None)
    | None ⇒ None))"

lemma list_cases4:
  "⋀x P. (x = [] ⟹ P) ⟹ (⋀y. x = [y] ⟹ P) ⟹
    (⋀y z. x = [y, z] ⟹ P) ⟹
    (⋀w y z zs. x = w # y # z # zs ⟹ P) ⟹ P"
  by (metis list.exhaust)

lemma bound_intersect_2d_ud_segments_of_aform_le:
  "bound_intersect_2d_ud prec X xl = Some (m0, M0) ⟹ m0 ≤ M0"
  by (cases "segments_of_aform X" rule: list_cases4)
    (auto simp: Let_def bound_intersect_2d_ud_def min_def max_def intersect_segment_xline_le
      if_split_eq1 split: option.split_asm prod.split_asm list.split_asm
      dest!: bound_intersect_2d_le)

lemma pdevs_domain_eq_empty_iff[simp]: "pdevs_domain (snd X) = {} ⟷ snd X = zero_pdevs"
  by (auto simp: intro!: pdevs_eqI)

lemma ccw_contr_on_line_left:
  assumes "det3 (a, b) (x, c) (x, d) ≥ 0" "a > x"
  shows "d ≤ c"
proof -
  from assms have "d * (a - x) ≤ c * (a - x)"
    by (auto simp: det3_def' algebra_simps)
  with assms show "c ≥ d" by auto
qed

lemma ccw_contr_on_line_right:
  assumes "det3 (a, b) (x, c) (x, d) ≥ 0" "a < x"
  shows "d ≥ c"
proof -
  from assms have "c * (x - a) ≤ d * (x - a)"
    by (auto simp: det3_def' algebra_simps)
  with assms show "d ≥ c" by auto
qed

lemma singleton_contrE:
  assumes "⋀x y. x ≠ y ⟹ x ∈ X ⟹ y ∈ X ⟹ False"
  assumes "X ≠ {}"
  obtains x where "X = {x}"
  using assms by blast

lemma segment_intersection_singleton:
  fixes xl and a b::"real * real"
  defines "i ≡ closed_segment a b ∩ {p. fst p = xl}"
  assumes ne1: "fst a ≠ fst b"
  assumes upper: "i ≠ {}"
  obtains p1 where "i = {p1}"
proof (rule singleton_contrE[OF _ upper])
  fix x y assume H: "x ≠ y" "x ∈ i" "y ∈ i"
  then obtain u v where uv: "x = u *⇩_R b + (1 - u) *⇩_R a" "y = v *⇩_R b + (1 - v) *⇩_R a"
    "0 ≤ u" "u ≤ 1" "0 ≤ v" "v ≤ 1"
    by (auto simp add: closed_segment_def i_def field_simps)
  then have "x + u *⇩_R a = a + u *⇩_R b" "y + v *⇩_R a = a + v *⇩_R b"
    by simp_all
  then have "fst (x + u *⇩_R a) = fst (a + u *⇩_R b)" "fst (y + v *⇩_R a) = fst (a + v *⇩_R b)"
    by simp_all
  then have "u = v * (fst a - fst b) / (fst a - fst b)"
    using ne1 H(2,3) ‹0 ≤ u› ‹u ≤ 1› ‹0 ≤ v› ‹v ≤ 1›
    by (simp add: closed_segment_def i_def field_simps)
  then have "u = v"
    by (simp add: ne1)
  then show False using H uv
    by simp
qed

lemma bound_intersect_2d_ud_segments_of_aform:
  assumes "bound_intersect_2d_ud prec X xl = Some (m0, M0)"
  assumes "e ∈ UNIV → {-1 .. 1}"
  shows "{aform_val e X} ∩ {x. fst x = xl} ⊆ {(xl, m0) .. (xl, M0)}"
proof safe
  fix a b
  assume safeassms: "(a, b) = aform_val e X" "xl = fst (a, b)"
  hence fst_aform_val: "fst (aform_val e X) = xl"
    by simp
  {
    assume len: "length (segments_of_aform X) > 2"
    with assms obtain m M m' M'
    where lb: "bound_intersect_2d prec
        [((x1, y1), x2, y2)←segments_of_aform X . x1 < x2] xl = Some (m, M')"
      and ub: "bound_intersect_2d prec
        [((x1, y1), x2, y2)←segments_of_aform X . x2 < x1] xl = Some (m', M)"
      and minmax: "m0 = min m m'" "M0 = max M M'"
      by (auto simp: bound_intersect_2d_ud_def split: option.split_asm list.split_asm )
    from bound_intersect_2d_upper[OF ub] obtain X1 m1
    where upper:
      "X1 ∈ set [((x1, y1), x2, y2)←segments_of_aform X . x2 < x1]"
      "intersect_segment_xline prec X1 xl = Some (m1, M)"
      by metis
    from bound_intersect_2d_lower[OF lb] obtain X2 M2
    where lower:
      "X2 ∈ set [((x1, y1), x2, y2)←segments_of_aform X . x1 < x2]"
      "intersect_segment_xline prec X2 xl = Some (m, M2)"
      by metis
    from upper(1) lower(1)
    have X1: "X1 ∈ set (segments_of_aform X)" "fst (fst X1) > fst (snd X1)"
      and X2: "X2 ∈ set (segments_of_aform X)" "fst (fst X2) < fst (snd X2)"
      by auto
    note upper_seg = intersect_segment_xline_fst_snd[OF upper(2)]
    note lower_seg = intersect_segment_xline_fst_snd[OF lower(2)]
    from len have lh: "length (half_segments_of_aform X) ≠ 1"
      by (auto simp: segments_of_aform_def Let_def)
    from X1 have ne1: "fst (fst X1) ≠ fst (snd X1)"
      by simp
    moreover have "closed_segment (fst X1) (snd X1) ∩ {p. fst p = xl} ≠ {}"
      using upper(2)
      by (simp add: intersect_segment_xline_None_iff[of prec, symmetric])
    ultimately obtain p1 where p1: "closed_segment (fst X1) (snd X1) ∩ {p. fst p = xl} = {p1}"
      by (rule segment_intersection_singleton)
    then obtain u where u: "p1 = (1 - u) *⇩_R fst X1 + u *⇩_R (snd X1)" "0 ≤ u" "u ≤ 1"
      by (auto simp: closed_segment_def algebra_simps)
    have coll1: "det3 (fst X1) p1 (aform_val e X) ≥ 0"
      and coll1': "det3 p1 (snd X1) (aform_val e X) ≥ 0"
      unfolding atomize_conj
      using u
      by (cases "u = 0 ∨ u = 1")
        (auto simp: u(1) intro: det3_nonneg_scaleR_segment1 det3_nonneg_scaleR_segment2
          det3_nonneg_segments_of_aformI[OF ‹e ∈ _› lh X1(1)])

    from X2 have ne2: "fst (fst X2) ≠ fst (snd X2)" by simp
    moreover
    have "closed_segment (fst X2) (snd X2) ∩ {p. fst p = xl} ≠ {}"
      using lower(2)
      by (simp add: intersect_segment_xline_None_iff[of prec, symmetric])
    ultimately
    obtain p2 where p2: "closed_segment (fst X2) (snd X2) ∩ {p. fst p = xl} = {p2}"
      by (rule segment_intersection_singleton)
    then obtain v where v: "p2 = (1 - v) *⇩_R fst X2 + v *⇩_R (snd X2)" "0 ≤ v" "v ≤ 1"
      by (auto simp: closed_segment_def algebra_simps)
    have coll2: "det3 (fst X2) p2 (aform_val e X) ≥ 0"
      and coll2': "det3 p2 (snd X2) (aform_val e X) ≥ 0"
      unfolding atomize_conj
      using v
      by (cases "v = 0 ∨ v = 1")
        (auto simp: v(1) intro: det3_nonneg_scaleR_segment1 det3_nonneg_scaleR_segment2
          det3_nonneg_segments_of_aformI[OF ‹e ∈ _› lh X2(1)])

    from in_set_segments_of_aform_aform_valE
        [of "fst X1" "snd X1" X, unfolded prod.collapse, OF X1(1)]
    obtain e1s where e1s: "snd X1 = aform_val e1s X" "e1s ∈ UNIV → {- 1..1}" .
    from previous_segments_of_aformE
        [of "fst X1" "snd X1" X, unfolded prod.collapse, OF X1(1)]
    obtain fX0 where "(fX0, fst X1) ∈ set (segments_of_aform X)" .
    from in_set_segments_of_aform_aform_valE[OF this]
    obtain e1f where e1f: "fst X1 = aform_val e1f X" "e1f ∈ UNIV → {- 1..1}" .
    have "p1 ∈ closed_segment (aform_val e1f X) (aform_val e1s X)"
      using p1 by (auto simp: e1s e1f)
    with segment_in_aform_val[OF e1s(2) e1f(2), of X]
    obtain ep1 where ep1: "ep1 ∈ UNIV → {-1 .. 1}" "p1 = aform_val ep1 X"
      by (auto simp: Affine_def valuate_def closed_segment_commute)

    from in_set_segments_of_aform_aform_valE
        [of "fst X2" "snd X2" X, unfolded prod.collapse, OF X2(1)]
    obtain e2s where e2s: "snd X2 = aform_val e2s X" "e2s ∈ UNIV → {- 1..1}" .
    from previous_segments_of_aformE
        [of "fst X2" "snd X2" X, unfolded prod.collapse, OF X2(1)]
    obtain fX02 where "(fX02, fst X2) ∈ set (segments_of_aform X)" .
    from in_set_segments_of_aform_aform_valE[OF this]
    obtain e2f where e2f: "fst X2 = aform_val e2f X" "e2f ∈ UNIV → {- 1..1}" .
    have "p2 ∈ closed_segment (aform_val e2f X) (aform_val e2s X)"
      using p2 by (auto simp: e2s e2f)
    with segment_in_aform_val[OF e2f(2) e2s(2), of X]
    obtain ep2 where ep2: "ep2 ∈ UNIV → {-1 .. 1}" "p2 = aform_val ep2 X"
      by (auto simp: Affine_def valuate_def)

    from det3_nonneg_segments_of_aformI[OF ep2(1), of X "(fst X1, snd X1)", unfolded prod.collapse,
        OF lh X1(1), unfolded ep2(2)[symmetric]]
    have c2: "det3 (fst X1) (snd X1) p2 ≥ 0" .
    hence c12: "det3 (fst X1) p1 p2 ≥ 0"
      using u by (cases "u = 0") (auto simp: u(1) det3_nonneg_scaleR_segment2)
    from det3_nonneg_segments_of_aformI[OF ep1(1), of X "(fst X2, snd X2)", unfolded prod.collapse,
        OF lh X2(1), unfolded ep1(2)[symmetric]]
    have c1: "det3 (fst X2) (snd X2) p1 ≥ 0" .
    hence c21: "det3 (fst X2) p2 p1 ≥ 0"
      using v by (cases "v = 0") (auto simp: v(1) det3_nonneg_scaleR_segment2)
    from p1 p2 have p1p2xl: "fst p1 = xl" "fst p2 = xl"
      by (auto simp: det3_def')
    from upper_seg p1 have "snd p1 ≤ M" by (auto simp: less_eq_prod_def)
    from lower_seg p2 have "m ≤ snd p2" by (auto simp: less_eq_prod_def)

    {
      have *: "(fst p1, snd (aform_val e X)) = aform_val e X"
        by (simp add: prod_eq_iff p1p2xl fst_aform_val)
      hence coll:
        "det3 (fst (fst X1), snd (fst X1)) (fst p1, snd p1) (fst p1, snd (aform_val e X)) ≥ 0"
        and coll':
        "det3 (fst (snd X1), snd (snd X1)) (fst p1, snd (aform_val e X)) (fst p1, snd p1) ≥ 0"
        using coll1 coll1'
        by (auto simp: det3_rotate)
      have "snd (aform_val e X) ≤ M"
      proof (cases "fst (fst X1) = xl")
        case False
        have "fst (fst X1) ≥ fst p1"
          unfolding u using X1
          by (auto simp: algebra_simps intro!: mult_left_mono u)
        moreover
        have "fst (fst X1) ≠ fst p1"
          using False
          by (simp add: p1p2xl)
        ultimately
        have "fst (fst X1) > fst p1" by simp
        from ccw_contr_on_line_left[OF coll this]
        show ?thesis using ‹snd p1 ≤ M› by simp
      next
        case True
        have "fst (snd X1) * (1 - u) ≤ fst (fst X1) * (1 - u)"
          using X1 u
          by (auto simp: intro!: mult_right_mono)
        hence "fst (snd X1) ≤ fst p1"
          unfolding u by (auto simp: algebra_simps)
        moreover
        have "fst (snd X1) ≠ fst p1"
          using True ne1
          by (simp add: p1p2xl)
        ultimately
        have "fst (snd X1) < fst p1" by simp
        from ccw_contr_on_line_right[OF coll' this]
        show ?thesis using ‹snd p1 ≤ M› by simp
      qed
    } moreover {
      have "(fst p2, snd (aform_val e X)) = aform_val e X"
        by (simp add: prod_eq_iff p1p2xl fst_aform_val)
      hence coll:
        "det3 (fst (fst X2), snd (fst X2)) (fst p2, snd p2) (fst p2, snd (aform_val e X)) ≥ 0"
        and coll':
        "det3 (fst (snd X2), snd (snd X2)) (fst p2, snd (aform_val e X)) (fst p2, snd p2) ≥ 0"
        using coll2 coll2'
        by (auto simp: det3_rotate)
      have "m ≤ snd (aform_val e X)"
      proof (cases "fst (fst X2) = xl")
        case False
        have "fst (fst X2) ≤ fst p2"
          unfolding v using X2
          by (auto simp: algebra_simps intro!: mult_left_mono v)
        moreover
        have "fst (fst X2) ≠ fst p2"
          using False
          by (simp add: p1p2xl)
        ultimately
        have "fst (fst X2) < fst p2" by simp
        from ccw_contr_on_line_right[OF coll this]
        show ?thesis using ‹m ≤ snd p2› by simp
      next
        case True
        have "(1 - v) * fst (snd X2) ≥ (1 - v) * fst (fst X2)"
          using X2 v
          by (auto simp: intro!: mult_left_mono)
        hence "fst (snd X2) ≥ fst p2"
          unfolding v by (auto simp: algebra_simps)
        moreover
        have "fst (snd X2) ≠ fst p2"
          using True ne2
          by (simp add: p1p2xl)
        ultimately
        have "fst (snd X2) > fst p2" by simp
        from ccw_contr_on_line_left[OF coll' this]
        show ?thesis using ‹m ≤ snd p2› by simp
      qed
    } ultimately have "aform_val e X ∈ {(xl, m) .. (xl, M)}"
      by (auto simp: less_eq_prod_def fst_aform_val)
    hence "aform_val e X ∈ {(xl, m0) .. (xl, M0)}"
      by (auto simp: minmax less_eq_prod_def)
  } moreover {
    assume "length (segments_of_aform X) = 2"
    then obtain a b where s: "segments_of_aform X = [a, b]"
      by (auto simp: numeral_2_eq_2 length_Suc_conv)
    from segments_of_aform_line_segment[OF this assms(2)]
    have "aform_val e X ∈ closed_segment (fst a) (snd a)" .
    moreover
    from assms
    have "intersect_segment_xline prec a xl = Some (m0, M0)"
      by (auto simp: bound_intersect_2d_ud_def s)
    note intersect_segment_xline_fst_snd[OF this]
    ultimately
    have "aform_val e X ∈ {(xl, m0) .. (xl, M0)}"
      by (auto simp: less_eq_prod_def fst_aform_val)
  } moreover {
    assume "length (segments_of_aform X) = 1"
    from polychain_of_segments_of_aform1[OF this]
    have "aform_val e X ∈ {(xl, m0) .. (xl, M0)}" by auto
  } moreover {
    assume len: "length (segments_of_aform X) = 0"
    hence "independent_pdevs (map snd (list_of_pdevs (nlex_pdevs (snd X)))) = []"
      by (simp add: segments_of_aform_def Let_def half_segments_of_aform_def inl_def)
    hence "snd X = zero_pdevs"
      by (subst (asm) independent_pdevs_eq_Nil_iff) (auto simp: list_all_iff list_of_pdevs_def)
    hence "aform_val e X = fst X"
      by (simp add: aform_val_def)
    with len assms have "aform_val e X ∈ {(xl, m0) .. (xl, M0)}"
      by (auto simp: bound_intersect_2d_ud_def Let_def split: if_split_asm)
  } ultimately have "aform_val e X ∈ {(xl, m0)..(xl, M0)}"
    by arith
  thus "(a, b) ∈ {(fst (a, b), m0)..(fst (a, b), M0)}"
    using safeassms
    by simp
qed


subsection ‹Approximation from Orthogonal Directions›

definition inter_aform_plane_ortho::
  "nat ⇒ 'a::executable_euclidean_space aform ⇒ 'a ⇒ real ⇒ 'a aform option"
  where
  "inter_aform_plane_ortho p Z n g = do {
    mMs ← those (map (λb. bound_intersect_2d_ud p (inner2_aform Z n b) g) Basis_list);
    let l = (∑(b, m)←zip Basis_list (map fst mMs). m *⇩_R b);
    let u = (∑(b, M)←zip Basis_list (map snd mMs). M *⇩_R b);
    Some (aform_of_ivl l u)
  }"

lemma
  those_eq_SomeD:
  assumes "those (map f xs) = Some ys"
  shows "ys = map (the o f) xs ∧ (∀i.∃y. i < length xs ⟶ f (xs ! i) = Some y)"
  using assms
  by (induct xs arbitrary: ys) (auto split: option.split_asm simp: o_def nth_Cons split: nat.split)

lemma
  sum_list_zip_map:
  assumes "distinct xs"
  shows "(∑(x, y)←zip xs (map g xs). f x y) = (∑x∈set xs. f x (g x))"
  by (force simp add: sum_list_distinct_conv_sum_set assms distinct_zipI1 split_beta'
    in_set_zip in_set_conv_nth inj_on_convol_ident
    intro!: sum.reindex_cong[where l="λx. (x, g x)"])

lemma
  inter_aform_plane_ortho_overappr:
  assumes "inter_aform_plane_ortho p Z n g = Some X"
  shows "{x. ∀i ∈ Basis. x ∙ i ∈ {y. (g, y) ∈ (λx. (x ∙ n, x ∙ i)) ` Affine Z}} ⊆ Affine X"
proof -
  let ?inter = "(λb. bound_intersect_2d_ud p (inner2_aform Z n b) g)"
  obtain xs
  where xs: "those (map ?inter Basis_list) = Some xs"
    using assms by (cases "those (map ?inter Basis_list)") (auto simp: inter_aform_plane_ortho_def)

  from those_eq_SomeD[OF this]
  obtain y' where xs_eq: "xs = map (the ∘ ?inter) Basis_list"
    and y': "⋀i. i < length (Basis_list::'a list) ⟹ ?inter (Basis_list ! i) = Some (y' i)"
    by metis
  have "∀(i::'a) ∈ Basis. ∃j<length (Basis_list::'a list). i = Basis_list ! j"
    by (metis Basis_list in_set_conv_nth)
  then obtain j where j:
    "⋀i::'a. i∈Basis ⟹ j i < length (Basis_list::'a list)"
    "⋀i::'a. i∈Basis ⟹ i = Basis_list ! j i"
    by metis
  define y where "y = y' o j"
  with y' j have y: "⋀i. i ∈ Basis ⟹ ?inter i = Some (y i)"
    by (metis comp_def)
  hence y_le: "⋀i. i ∈ Basis ⟹ fst (y i) ≤ snd (y i)"
    by (auto intro!: bound_intersect_2d_ud_segments_of_aform_le)
  hence "(∑b∈Basis. fst (y b) *⇩_R b) ≤ (∑b∈Basis. snd (y b) *⇩_R b)"
    by (auto simp: eucl_le[where 'a='a])
  with assms have X: "Affine X = {∑b∈Basis. fst (y b) *⇩_R b..∑b∈Basis. snd (y b) *⇩_R b}"
    by (auto simp: inter_aform_plane_ortho_def sum_list_zip_map xs xs_eq y Affine_aform_of_ivl)

  show ?thesis
  proof safe
    fix x assume x: "∀i∈Basis. x ∙ i ∈ {y. (g, y) ∈ (λx. (x ∙ n, x ∙ i)) ` Affine Z}"
    {
      fix i::'a assume i: "i ∈ Basis"
      from x i have x_in2: "(g, x ∙ i) ∈ (λx. (x ∙ n, x ∙ i)) ` Affine Z"
        by auto
      from x_in2 obtain e
      where e: "e ∈ UNIV → {- 1..1}"
        and g: "g = aform_val e Z ∙ n"
        and x: "x ∙ i = aform_val e Z ∙ i"
        by (auto simp: Affine_def valuate_def)
      have "{aform_val e (inner2_aform Z n i)} = {aform_val e (inner2_aform Z n i)} ∩ {x. fst x = g}"
        by (auto simp: g inner2_def)
      also
      from y[OF ‹i ∈ Basis›]
      have "?inter i = Some (fst (y i), snd (y i))" by simp
      note bound_intersect_2d_ud_segments_of_aform[OF this e]
      finally have "x ∙ i ∈ {fst (y i) .. snd (y i)}"
        by (auto simp: x inner2_def)
    } thus "x ∈ Affine X"
      unfolding X
      by (auto simp: eucl_le[where 'a='a])
  qed
qed

lemma inter_proj_eq:
  fixes n g l
  defines "G ≡ {x. x ∙ n = g}"
  shows "(λx. x ∙ l) ` (Z ∩ G) =
    {y. (g, y) ∈ (λx. (x ∙ n, x ∙ l)) ` Z}"
  by (auto simp: G_def)

lemma
  inter_overappr:
  fixes n γ l
  shows "Z ∩ {x. x ∙ n = g} ⊆ {x. ∀i ∈ Basis. x ∙ i ∈ {y. (g, y) ∈ (λx. (x ∙ n, x ∙ i)) ` Z}}"
  by auto

lemma inter_inter_aform_plane_ortho:
  assumes "inter_aform_plane_ortho p Z n g = Some X"
  shows "Affine Z ∩ {x. x ∙ n = g} ⊆ Affine X"
proof -
  note inter_overappr[of "Affine Z" n g]
  also note inter_aform_plane_ortho_overappr[OF assms]
  finally show ?thesis .
qed

subsection ‹``Completeness'' of Intersection›

abbreviation "encompasses x seg ≡ det3 (fst seg) (snd seg) x ≥ 0"

lemma encompasses_cases:
  "encompasses x seg ∨ encompasses x (snd seg, fst seg)"
  by (auto simp: det3_def' algebra_simps)

lemma list_all_encompasses_cases:
  assumes "list_all (encompasses p) (x # y # zs)"
  obtains "list_all (encompasses p) [x, y, (snd y, fst x)]"
    | "list_all (encompasses p) ((fst x, snd y)#zs)"
  using encompasses_cases
proof
  assume "encompasses p (snd y, fst x)"
  hence "list_all (encompasses p) [x, y, (snd y, fst x)]"
    using assms by (auto simp: list_all_iff)
  thus ?thesis ..
next
  assume "encompasses p (snd (snd y, fst x), fst (snd y, fst x))"
  hence "list_all (encompasses p) ((fst x, snd y)#zs)"
    using assms by (auto simp: list_all_iff)
  thus ?thesis ..
qed

lemma triangle_encompassing_polychain_of:
  assumes "det3 p a b ≥ 0" "det3 p b c ≥ 0" "det3 p c a ≥ 0"
  assumes "ccw' a b c"
  shows "p ∈ convex hull {a, b, c}"
proof -
  from assms have nn: "det3 b c p ≥ 0" "det3 c a p ≥ 0" "det3 a b p ≥ 0" "det3 a b c ≥ 0"
    by (auto simp: det3_def' algebra_simps)
  have "det3 a b c *⇩_R p = det3 b c p *⇩_R a + det3 c a p *⇩_R b + det3 a b p *⇩_R c"
    by (auto simp: det3_def' algebra_simps prod_eq_iff)
  hence "inverse (det3 a b c) *⇩_R (det3 a b c *⇩_R p) =
      inverse (det3 a b c) *⇩_R (det3 b c p *⇩_R a + det3 c a p *⇩_R b + det3 a b p *⇩_R c)"
    by simp
  with assms have p_eq: "p =
    (det3 b c p / det3 a b c) *⇩_R a + (det3 c a p / det3 a b c) *⇩_R b + (det3 a b p / det3 a b c) *⇩_R c"
    (is "_ = scaleR ?u _ + scaleR ?v _ + scaleR ?w _")
    by (simp add: inverse_eq_divide algebra_simps ccw'_def)
  have det_eq: "det3 b c p / det3 a b c + det3 c a p / det3 a b c + det3 a b p / det3 a b c = 1"
    using assms(4)
    by (simp add: add_divide_distrib[symmetric] det3_def' algebra_simps ccw'_def)
  show ?thesis
    unfolding convex_hull_3
    using assms(4)
    by (blast intro: exI[where x="?u"] exI[where x="?v"] exI[where x="?w"]
      intro!: p_eq divide_nonneg_nonneg nn det_eq)
qed

lemma encompasses_convex_polygon3:
  assumes "list_all (encompasses p) (x#y#z#zs)"
  assumes "convex_polygon (x#y#z#zs)"
  assumes "ccw'.sortedP (fst x) (map snd (butlast (x#y#z#zs)))"
  shows "p ∈ convex hull (set (map fst (x#y#z#zs)))"
  using assms
proof (induct zs arbitrary: x y z p)
  case Nil
  thus ?case
    by (auto simp: det3_def' algebra_simps
      elim!: ccw'.sortedP_Cons ccw'.sortedP_Nil
      intro!: triangle_encompassing_polychain_of)
next
  case (Cons w ws)
  from Cons.prems(2) have "snd y = fst z" by auto
  from Cons.prems(1)
  show ?case
  proof (rule list_all_encompasses_cases)
    assume "list_all (encompasses p) [x, y, (snd y, fst x)]"
    hence "p ∈ convex hull {fst x, fst y, snd y}"
      using Cons.prems
      by (auto simp: det3_def' algebra_simps
        elim!: ccw'.sortedP_Cons ccw'.sortedP_Nil
        intro!: triangle_encompassing_polychain_of)
    thus ?case
      by (rule rev_subsetD[OF _ hull_mono]) (auto simp: ‹snd y = fst z›)
  next
    assume *: "list_all (encompasses p) ((fst x, snd y) # z # w # ws)"
    from Cons.prems
    have enc: "ws ≠ [] ⟹ encompasses p (last ws)"
      by (auto simp: list_all_iff)
    have "set (map fst ((fst x, snd y)#z#w#ws)) ⊆ set (map fst (x # y # z # w # ws))"
      by auto
    moreover
    {
      note *
      moreover
      have "convex_polygon ((fst x, snd y) # z # w # ws)"
        by (metis convex_polygon_skip Cons.prems(2,3))
      moreover
      have "ccw'.sortedP (fst (fst x, snd y)) (map snd (butlast ((fst x, snd y) # z # w # ws)))"
        using Cons.prems(3)
        by (auto elim!: ccw'.sortedP_Cons intro!: ccw'.sortedP.Cons ccw'.sortedP.Nil
          split: if_split_asm)
      ultimately have "p ∈ convex hull set (map fst ((fst x, snd y)#z#w#ws))"
        by (rule Cons.hyps)
    }
    ultimately
    show "p ∈ convex hull set (map fst (x # y # z # w # ws))"
      by (rule subsetD[OF hull_mono])
  qed
qed

lemma segments_of_aform_empty_Affine_eq:
  assumes "segments_of_aform X = []"
  shows "Affine X = {fst X}"
proof -
  have "independent_pdevs (map snd (list_of_pdevs (nlex_pdevs (snd X)))) = [] ⟷
    (list_of_pdevs (nlex_pdevs (snd X))) = []"
    by (subst independent_pdevs_eq_Nil_iff) (auto simp: list_all_iff list_of_pdevs_def )
  with assms show ?thesis
    by (force simp: aform_val_def list_of_pdevs_def Affine_def valuate_def segments_of_aform_def
      Let_def half_segments_of_aform_def inl_def)
qed

lemma not_segments_of_aform_singleton: "segments_of_aform X ≠ [x]"
  by (auto simp: segments_of_aform_def Let_def add_is_1 dest!: arg_cong[where f=length])

lemma encompasses_segments_of_aform_in_AffineI:
  assumes "length (segments_of_aform X) > 2"
  assumes "list_all (encompasses p) (segments_of_aform X)"
  shows "p ∈ Affine X"
proof -
  from assms(1) obtain x y z zs where eq: "segments_of_aform X = x#y#z#zs"
    by (cases "segments_of_aform X" rule: list_cases4) auto
  hence "fst x = fst (hd (half_segments_of_aform X))"
    by (metis segments_of_aform_def hd_append list.map_disc_iff list.sel(1))
  also have "… = lowest_vertex (fst X, nlex_pdevs (snd X))"
    using assms
    by (intro fst_hd_half_segments_of_aform) (auto simp: segments_of_aform_def)
  finally have fstx: "fst x = lowest_vertex (fst X, nlex_pdevs (snd X))" .
  have "p ∈ convex hull (set (map fst (segments_of_aform X)))"
    using assms(2)
    unfolding eq
  proof (rule encompasses_convex_polygon3)
    show "convex_polygon (x # y # z # zs)"
      using assms(1) unfolding eq[symmetric]
      by (intro convex_polygon_segments_of_aform) (simp add: segments_of_aform_def Let_def)
    show "ccw'.sortedP (fst x) (map snd (butlast (x # y # z # zs)))"
      using assms(1)
      unfolding fstx map_butlast eq[symmetric]
      by (intro ccw'_sortedP_snd_segments_of_aform)
        (simp add: segments_of_aform_def Let_def half_segments_of_aform_def)
  qed
  also have "… ⊆ convex hull (Affine X)"
  proof (rule hull_mono, safe)
    fix a b assume "(a, b) ∈ set (map fst (segments_of_aform X))"
    then obtain c d where "((a, b), c, d) ∈ set (segments_of_aform X)" by auto
    from previous_segments_of_aformE[OF this]
    obtain x where "(x, a, b) ∈ set (segments_of_aform X)" by auto
    from in_set_segments_of_aform_aform_valE[OF this]
    obtain e where "(a, b) = aform_val e X" "e ∈ UNIV → {- 1..1}" by auto
    thus "(a, b) ∈ Affine X"
      by (auto simp: Affine_def valuate_def image_iff)
  qed
  also have "… = Affine X"
    by (simp add: convex_Affine convex_hull_eq)
  finally show ?thesis .
qed

end

Theory Affine_Arithmetic_Auxiliarities

Theory Executable_Euclidean_Space

Theory Affine_Form

Theory Floatarith_Expression

Theory Straight_Line_Program

Theory Affine_Approximation

Theory Counterclockwise

Theory Counterclockwise_Vector

Theory Counterclockwise_2D_Strict

Theory Polygon

Theory Counterclockwise_2D_Arbitrary

Theory Intersection

Theory Affine_Code

Theory Optimize_Integer

Theory Optimize_Float

Theory Print

Theory Float_Real

Theory Ex_Affine_Approximation

Theory Ex_Ineqs

Theory Ex_Inter

Theory Affine_Arithmetic